diff --git a/default-recommendations/analyzers/expansion-context-analyzer-test.rkt b/default-recommendations/analyzers/expansion-context-analyzer-test.rkt new file mode 100644 index 0000000..6a71675 --- /dev/null +++ b/default-recommendations/analyzers/expansion-context-analyzer-test.rkt @@ -0,0 +1,29 @@ +#lang resyntax/test + + +require: resyntax/default-recommendations/analyzers/expansion-context-analyzer expansion-context-analyzer +header: - #lang racket/base + + +analysis-test: "code in a module is in a module context" +- (+ 1 2 3) +@inspect - (+ 1 2 3) +@property expansion-context +@assert module + + +analysis-test: "function arguments are in an expression context" +- (+ 1 2 3) +@inspect - 2 +@property expansion-context +@assert expression + + +analysis-test: "code in a function body is in an internal definition context" +-------------------- +(define (f) + (+ 1 2 3)) +-------------------- +@inspect - (+ 1 2 3) +@property expansion-context +@assert internal-definition diff --git a/default-recommendations/analyzers/expansion-context-analyzer.rkt b/default-recommendations/analyzers/expansion-context-analyzer.rkt new file mode 100644 index 0000000..edc2089 --- /dev/null +++ b/default-recommendations/analyzers/expansion-context-analyzer.rkt @@ -0,0 +1,86 @@ +#lang racket/base + + +(require racket/contract/base) + + +(provide + (contract-out + [expansion-context-analyzer expansion-analyzer?])) + + +(require racket/stream + rebellion/streaming/transducer + resyntax/private/analyzer + resyntax/private/syntax-path + resyntax/private/syntax-property-bundle + resyntax/private/syntax-traversal + syntax/parse) + + +;@---------------------------------------------------------------------------------------------------- + + +(define (annotate-expansion-contexts expanded-stx) + (let loop ([expanded-stx expanded-stx] [phase 0]) + (syntax-search expanded-stx + #:literal-sets ([kernel-literals #:phase phase]) + + ;; Phase mismatch - recurse with correct phase + [(id:id _ ...) + #:do [(define id-phase (syntax-property (attribute id) 'phase))] + #:when (not (equal? id-phase phase)) + (loop this-syntax id-phase)] + + ;; Skip quote-syntax - no expansion context inside + [(quote-syntax _) (stream)] + + ;; Forms directly under #%module-begin are in module context + [(#%module-begin form ...) + (for/stream ([form-stx (in-list (attribute form))]) + (define path (syntax-property form-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'module)))] + + ;; Body forms of lambda are in internal-definition context + [(lambda formals body ...+) + (for/stream ([body-stx (in-list (attribute body))]) + (define path (syntax-property body-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'internal-definition)))] + + ;; Body forms of case-lambda are in internal-definition context + [(case-lambda [formals body ...+] ...) + (for*/stream ([bodies (in-list (attribute body))] + [body-stx (in-list bodies)]) + (define path (syntax-property body-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'internal-definition)))] + + ;; Body forms of let-values and letrec-values are in internal-definition context + [(~or (let-values ([vars rhs] ...) body ...+) + (letrec-values ([vars rhs] ...) body ...+)) + (stream-append + ;; RHS expressions are in expression context + (for/stream ([rhs-stx (in-list (attribute rhs))]) + (define path (syntax-property rhs-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'expression))) + ;; Body forms are in internal-definition context + (for/stream ([body-stx (in-list (attribute body))]) + (define path (syntax-property body-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'internal-definition))))] + + ;; Subforms of #%plain-app (function applications) are in expression context + [(app-id:id subform ...) + #:when (free-identifier=? (attribute app-id) #'#%plain-app) + (stream-filter + values + (for/stream ([subform-stx (in-list (attribute subform))]) + (define path (syntax-property subform-stx 'expansion-path)) + (and path (syntax-property-entry path 'expansion-context 'expression))))]))) + + +(define expansion-context-analyzer + (make-expansion-analyzer + #:name 'expansion-context-analyzer + (λ (expanded-stx) + (define labeled-stx (syntax-label-paths expanded-stx 'expansion-path)) + (transduce (annotate-expansion-contexts labeled-stx) + #:into into-syntax-property-bundle))))