From c2b02202083c3ef2c7e5fdf9e3d1f9dff7f380a5 Mon Sep 17 00:00:00 2001 From: Jack Firth Date: Thu, 12 Sep 2024 03:06:48 -0700 Subject: [PATCH] Add full expansion scopes to visited syntax (#279) Closes #276. This allows a complete rework and immense simplification of the `let-to-define` logic. It also removes the need to pass the full source code analysis object to each refactoring rule, since all of the information produced by the analysis is now embedded in the syntax object handed to the refactoring rule. This commit also adds some miscellaneous observability improvements, including more debug logging and better error messages. --- .../for-loop-shortcuts-test.rkt | 18 +- .../for-loop-shortcuts.rkt | 17 +- .../function-definition-shortcuts.rkt | 16 +- .../let-binding-suggestions-test.rkt | 36 ++ .../let-binding-suggestions.rkt | 10 +- .../private/let-binding.rkt | 510 +++--------------- main.rkt | 2 +- private/linemap.rkt | 13 +- private/source.rkt | 117 ++-- refactoring-rule.rkt | 25 +- 10 files changed, 250 insertions(+), 514 deletions(-) diff --git a/default-recommendations/for-loop-shortcuts-test.rkt b/default-recommendations/for-loop-shortcuts-test.rkt index e035818..8228ce3 100644 --- a/default-recommendations/for-loop-shortcuts-test.rkt +++ b/default-recommendations/for-loop-shortcuts-test.rkt @@ -263,7 +263,8 @@ test: "for/and with or to filter clause" test: "for/fold building hash to for/hash" ------------------------------ -(for/fold ([h (hash)]) ([x (in-range 0 10)]) +(for/fold ([h (hash)]) + ([x (in-range 0 10)]) (hash-set h x 'foo)) ------------------------------ ------------------------------ @@ -274,7 +275,8 @@ test: "for/fold building hash to for/hash" test: "for*/fold building hash to for*/hash" ------------------------------ -(for*/fold ([h (hash)]) ([x (in-range 0 10)]) +(for*/fold ([h (hash)]) + ([x (in-range 0 10)]) (hash-set h x 'foo)) ------------------------------ ------------------------------ @@ -285,18 +287,18 @@ test: "for*/fold building hash to for*/hash" test: "for/fold building hash can't be refactored when referring to hash" ------------------------------ -(for/fold ([h (hash)]) ([x (in-range 0 10)]) - (displayln - (hash-has-key? h x)) +(for/fold ([h (hash)]) + ([x (in-range 0 10)]) + (displayln (hash-has-key? h x)) (hash-set h x 'foo)) ------------------------------ test: "for*/fold building hash can't be refactored when referring to hash" ------------------------------ -(for*/fold ([h (hash)]) ([x (in-range 0 10)]) - (displayln - (hash-has-key? h x)) +(for*/fold ([h (hash)]) + ([x (in-range 0 10)]) + (displayln (hash-has-key? h x)) (hash-set h x 'foo)) ------------------------------ diff --git a/default-recommendations/for-loop-shortcuts.rkt b/default-recommendations/for-loop-shortcuts.rkt index a67203f..394fbd4 100644 --- a/default-recommendations/for-loop-shortcuts.rkt +++ b/default-recommendations/for-loop-shortcuts.rkt @@ -23,6 +23,7 @@ resyntax/default-recommendations/private/syntax-identifier-sets resyntax/default-recommendations/private/syntax-lines resyntax/private/identifier-naming + resyntax/private/logger resyntax/private/syntax-neighbors resyntax/private/syntax-traversal syntax/parse) @@ -204,13 +205,21 @@ (define-refactoring-rule for/fold-building-hash-to-for/hash #:description "This `for` loop is building a hash and can be simplified." - #:literals (for/fold for*/fold hash make-immutable-hash) - ((~or (~and for/fold (~bind [loop #'for/hash])) (~and for*/fold (~bind [loop #'for*/hash]))) + #:literals (for/fold for*/fold hash make-immutable-hash hash-set) + ((~or (~and for/fold (~bind [loop #'for/hash])) + (~and for*/fold (~bind [loop #'for*/hash]))) ([h:id (~or (hash) (make-immutable-hash))]) iteration-clauses body ... (hash-set h-usage:id key value)) - #:when (free-identifier=? #'h #'h-usage) - #:when (not (set-member? (syntax-free-identifiers #'(body ...)) #'h)) + + ;; The expansion of for/fold is very complex, and one thing it does is mess with the accumulator ids + ;; and their uses such that free-identifier=? on an accumulator's use and its binder breaks. To work + ;; around this, we compare the hash usage and hash accumulator ids by symbol here. + #:when (equal? (syntax-e #'h) (syntax-e #'h-usage)) + + #:do [(define body-ids (syntax-free-identifiers #'(body ...)))] + #:when (and (not (set-member? body-ids #'h)) + (not (set-member? body-ids #'h-usage))) (loop iteration-clauses body ... (values key value))) diff --git a/default-recommendations/function-definition-shortcuts.rkt b/default-recommendations/function-definition-shortcuts.rkt index 670a75f..6051801 100644 --- a/default-recommendations/function-definition-shortcuts.rkt +++ b/default-recommendations/function-definition-shortcuts.rkt @@ -80,14 +80,26 @@ (define-refactoring-rule define-case-lambda-to-define #:description "This use of `case-lambda` is equivalent to using `define` with optional arguments." #:literals (define case-lambda) + (define id:id (case-lambda [(case1-arg:id ...) (usage:id usage1:id ... default:expr)] [(case2-arg:id ... bonus-arg:id) body ...])) + #:when (oneline-syntax? #'default) #:when (free-identifier=? #'id #'usage) - #:when (free-identifiers=? #'(case1-arg ...) #'(case2-arg ...)) - #:when (free-identifiers=? #'(case1-arg ...) #'(usage1 ...)) + + #:when (and (equal? (length (attribute case1-arg)) + (length (attribute case2-arg))) + (equal? (length (attribute case1-arg)) + (length (attribute usage1)))) + + #:when (for/and ([case1-arg-id (in-list (attribute case1-arg))] + [case2-arg-id (in-list (attribute case2-arg))] + [usage1-id (in-list (attribute usage1))]) + (and (equal? (syntax-e case1-arg-id) (syntax-e case2-arg-id)) + (equal? (syntax-e case1-arg-id) (syntax-e usage1-id)))) + (define (id case2-arg ... [bonus-arg default]) body ...)) diff --git a/default-recommendations/let-binding-suggestions-test.rkt b/default-recommendations/let-binding-suggestions-test.rkt index 18d35ed..65839b7 100644 --- a/default-recommendations/let-binding-suggestions-test.rkt +++ b/default-recommendations/let-binding-suggestions-test.rkt @@ -235,6 +235,33 @@ test: "self-shadowing let*-values binding clause isn't refactorable" ------------------------------ +test: "let* with later right-hand-sides referring to earlier bindings is refactorable" +------------------------------ +(define (f a) + (let* ([b (+ a 1)] + [c (+ b 1)] + [d (+ c 1)]) + d)) +------------------------------ +------------------------------ +(define (f a) + (define b (+ a 1)) + (define c (+ b 1)) + (define d (+ c 1)) + d) +------------------------------ + + +test: "let* with later bindings shadowing earlier right-hand-sides not refactorable" +------------------------------ +(define y 1) +(define (f) + (let* ([x (+ y 1)] + [y (+ x 1)]) + 1)) +------------------------------ + + test: "let forms inside lambdas" ------------------------------ (λ () @@ -503,6 +530,15 @@ test: "variable definition with nested let binding of name bound earlier not ref ------------------------------ +test: "variable definition with nested let binding shadowing name used later not refactorable" +------------------------------ +(define x 5) +(define (f) + (define y (let ([x 1]) (* x 2))) + (* x y)) +------------------------------ + + test: "let binding nested in begin0 extractable to definition" ------------------------------ (define (f) diff --git a/default-recommendations/let-binding-suggestions.rkt b/default-recommendations/let-binding-suggestions.rkt index 803608b..3f61b33 100644 --- a/default-recommendations/let-binding-suggestions.rkt +++ b/default-recommendations/let-binding-suggestions.rkt @@ -31,6 +31,7 @@ resyntax/refactoring-rule resyntax/refactoring-suite resyntax/private/syntax-neighbors + syntax/id-set syntax/parse) @@ -71,8 +72,11 @@ (~seq body-before ... (define id:id (let ([nested-id:id nested-expr:expr]) expr:expr)) body-after ...) - #:when (not - (set-member? (syntax-bound-identifiers #'(body-before ... id body-after ...)) #'nested-id)) + #:when (identifier-binding-unchanged-in-context? (attribute id) (attribute nested-expr)) + #:when (for/and ([body-free-id + (in-free-id-set + (syntax-free-identifiers #'(body-before ... nested-expr body-after ...)))]) + (identifier-binding-unchanged-in-context? body-free-id (attribute nested-id))) (body-before ... (define nested-id nested-expr) (define id expr) @@ -97,7 +101,7 @@ #:description "This `let` binding does nothing and can be removed." #:literals (let) (let ([left-id:id right-id:id]) body) - #:when (bound-identifier=? #'left-id #'right-id) + #:when (equal? (syntax-e (attribute left-id)) (syntax-e (attribute right-id))) body) diff --git a/default-recommendations/private/let-binding.rkt b/default-recommendations/private/let-binding.rkt index 29cbb54..1634a8a 100644 --- a/default-recommendations/private/let-binding.rkt +++ b/default-recommendations/private/let-binding.rkt @@ -1,452 +1,120 @@ #lang racket/base -(provide body-with-refactorable-let-expression - refactorable-let-expression) +(require racket/contract/base) -(require guard - racket/list +(provide + body-with-refactorable-let-expression + refactorable-let-expression + (contract-out + [identifier-binding-unchanged-in-context? (-> identifier? syntax? boolean?)] + [identifier-has-exact-binding-in-context? (-> identifier? syntax? boolean?)])) + + +(require racket/list racket/match - racket/sequence - racket/set - racket/syntax - rebellion/base/option - rebellion/collection/entry - rebellion/private/static-name - rebellion/streaming/reducer - rebellion/streaming/transducer - rebellion/type/record - resyntax/default-recommendations/private/graph - resyntax/private/source + resyntax/default-recommendations/private/syntax-identifier-sets + resyntax/default-recommendations/private/lambda-by-any-name resyntax/private/syntax-neighbors - resyntax/refactoring-rule + resyntax/private/logger syntax/id-set syntax/parse - syntax/parse/lib/function-header - syntax/stx) - - -(module+ test - (require (submod "..") - rackunit)) + syntax/parse/lib/function-header) ;@---------------------------------------------------------------------------------------------------- -(define-syntax-class refactorable-let-expression +(define-splicing-syntax-class body-with-refactorable-let-expression #:attributes ([refactored 1]) - #:literals (let let-values let* let*-values) - (pattern - ((~or* let let-values) ~! bindings:refactorable-let-bindings body:body-forms) - - #:when (no-binding-overlap? - (in-syntax #'(body.bound-id ...)) (in-syntax #'(bindings.inner-bound-id ...))) + (~seq leading-body ... let-expression:refactorable-let-expression) + #:with (refactored ...) #'(leading-body ... (~@ let-expression.refactored ...)))) - #:when (no-binding-conflicts? (attribute bindings.bound-id) #'body.scopes) - - #:when (attribute bindings.fully-refactorable?) - #:with (binding-definition ...) - #'(~splicing-replacement (bindings.outer-definition ...) #:original bindings) - #:with (refactored ...) - #`(~splicing-replacement (binding-definition ... body.formatted ...) #:original #,this-syntax)) - (pattern ((~or* let* let*-values) ~! bindings:refactorable-let*-bindings body:body-forms) - - #:when (no-binding-overlap? - (in-syntax #'(body.bound-id ...)) (in-syntax #'(bindings.inner-bound-id ...))) - - #:when (attribute bindings.fully-refactorable?) - #:with (binding-definition ...) - #'(~splicing-replacement (bindings.outer-definition ...) #:original bindings) - #:with (refactored ...) - #`(~splicing-replacement (binding-definition ... body.formatted ...) - #:original #,this-syntax))) - - -(define-splicing-syntax-class body-with-refactorable-let-expression +(define-syntax-class refactorable-let-expression #:attributes ([refactored 1]) #:literals (let let-values let* let*-values) - (pattern - (~seq - leading-body:body-forms - (~and let-expression - ((~or* let let-values) ~! bindings:refactorable-let-bindings inner-body:body-forms))) - - #:when (no-binding-overlap? (syntax-identifiers #'leading-body) - (in-syntax #'(bindings.outer-bound-id ...))) - #:when (no-binding-overlap? (in-syntax #'(inner-body.bound-id ...)) - (in-syntax #'(bindings.inner-bound-id ...))) - - #:when (no-binding-conflicts? (attribute bindings.bound-id) #'inner-body.scopes) - - #:when (attribute bindings.fully-refactorable?) - - #:with (binding-definition ...) - #'(~splicing-replacement (bindings.outer-definition ...) #:original bindings) - - #:with (refactored ...) - #'(leading-body.formatted ... - (~@ . (~splicing-replacement (binding-definition ... inner-body.formatted ...) - #:original let-expression)))) - - (pattern - (~seq - leading-body:body-forms - (~and let-expression - ((~or* let* let*-values) ~! bindings:refactorable-let*-bindings inner-body:body-forms))) - - #:when (no-binding-overlap? (syntax-identifiers #'leading-body) - (in-syntax #'(bindings.outer-bound-id ...))) - #:when (no-binding-overlap? (in-syntax #'(inner-body.bound-id ...)) - (in-syntax #'(bindings.inner-bound-id ...))) - - #:when (no-binding-conflicts? (attribute bindings.bound-id) #'inner-body.scopes) - - #:when (attribute bindings.fully-refactorable?) - - #:with (binding-definition ...) - #'(~splicing-replacement (bindings.outer-definition ...) #:original bindings) - + (~or ((~or let let-values) ~! bindings:binding-group body ...+) + ((~or let* let*-values) ~! (~var bindings (binding-group #:nested? #true)) body ...+)) + #:when (for/and ([id (attribute bindings.id)]) + (not (identifier-has-exact-binding-in-context? id this-syntax))) + #:when (for/and ([id (attribute bindings.id)]) + (identifier-binding-unchanged-in-context? id (first (attribute body)))) #:with (refactored ...) - #'(leading-body.formatted ... - (~@ . (~splicing-replacement (binding-definition ... inner-body.formatted ...) - #:original let-expression))))) - - -(module+ test - (test-case (name-string body-with-refactorable-let-expression) - - (define (parse stx) - (syntax-parse stx - [(let-expr:body-with-refactorable-let-expression) (syntax->datum #'(let-expr.refactored ...))] - [_ #false])) - - (test-case "refactorable let bindings after non-conflicting definitions" - (define stx #'((define a 1) (let ([b a]) (+ a b)))) - (define expected - '((define a 1) - (define b a) - (+ a b))) - (check-equal? (parse stx) expected)) - - (test-case "refactorable let* bindings after non-conflicting definitions" - (define stx #'((define a 1) (let* ([b a]) (+ a b)))) - (define expected - '((define a 1) - (define b a) - (+ a b))) - (check-equal? (parse stx) expected)) - - (test-case "refactorable let bindings after conflicting definitions" - (define stx #'((define a 1) (let ([a 2]) a))) - (check-false (parse stx))) - - (test-case "refactorable let* bindings after conflicting definitions" - (define stx #'((define a 1) (let* ([a 2]) a))) - (check-false (parse stx))) - - (test-case "refactorable let bindings after capturing definitions" - (define stx #'((define a x) (let ([x 1]) (+ a x)))) - (check-false (parse stx))) - - (test-case "refactorable let* bindings after capturing definitions" - (define stx #'((define a x) (let* ([x 1]) (+ a x)))) - (check-false (parse stx))))) - - -(define-syntax-class refactorable-let-bindings - #:attributes ([bound-id 1] - [outer-bound-id 1] - [inner-bound-id 1] - [outer-definition 1] - fully-refactorable?) - (pattern (clause:binding-clause ...) - #:with (bound-id ...) - (append-map parsed-binding-clause-bound-identifiers (attribute clause.parsed)) - #:do - [(define parsed-clauses (vector->immutable-vector (list->vector (attribute clause.parsed)))) - (define deps (let-binding-clause-dependencies parsed-clauses)) - (define depgraph (edges->graph deps #:vertex-count (vector-length parsed-clauses))) - (define graph - (parsed-binding-graph - #:clauses parsed-clauses - #:dependencies depgraph)) - (define split (let-binding-graph-split graph))] - #:when (split-bindings-changed? split) - #:attr fully-refactorable? (split-bindings-fully-refactorable? split) - #:with (outer-bound-id ...) (split-bindings-outer-ids split) - #:with (inner-bound-id ...) (split-bindings-inner-ids split) - #:with (outer-definition ...) (split-bindings-outer-definitions split))) - - -(define-syntax-class refactorable-let*-bindings - #:attributes ([bound-id 1] - [outer-bound-id 1] - [inner-bound-id 1] - [outer-definition 1] - fully-refactorable?) - (pattern (clause:binding-clause ...) - #:with (bound-id ...) - (append-map parsed-binding-clause-bound-identifiers (attribute clause.parsed)) - #:do - [(define parsed-clauses (vector->immutable-vector (list->vector (attribute clause.parsed)))) - (define deps (let-binding-clause-dependencies parsed-clauses)) - (define depgraph (edges->graph deps #:vertex-count (vector-length parsed-clauses))) - (define graph - (parsed-binding-graph - #:clauses parsed-clauses - #:dependencies depgraph)) - (define split (let*-binding-graph-split graph))] - #:when (split-bindings-changed? split) - #:attr fully-refactorable? (split-bindings-fully-refactorable? split) - #:with (outer-bound-id ...) (split-bindings-outer-ids split) - #:with (inner-bound-id ...) (split-bindings-inner-ids split) - #:with (outer-definition ...) (split-bindings-outer-definitions split))) - - -(define (sequence->bound-id-set ids) - (immutable-bound-id-set (list->set (sequence->list ids)))) - - -(define (syntax-identifiers stx) - (cond - [(identifier? stx) (list stx)] - [(stx-list? stx) - (for*/list ([substx (in-syntax stx)] - [subid (in-list (syntax-identifiers substx))]) - subid)] - [else '()])) - - -(module+ test - (test-case "syntax-identifiers" - (check-equal? - (map syntax->datum (syntax-identifiers #'(hello (darkness #:my old) friend))) - (list 'hello 'darkness 'old 'friend)))) - - -(define (no-binding-overlap? ids other-ids) - (define id-set (sequence->bound-id-set ids)) - (define other-id-set (sequence->bound-id-set other-ids)) - (bound-id-set-empty? (bound-id-set-intersect id-set other-id-set))) - - -(module+ test - (test-case "no-binding-overlap?" - (check-true (no-binding-overlap? (in-syntax #'(a b c)) (in-syntax #'(d e f)))) - (check-false (no-binding-overlap? (in-syntax #'(a b c)) (in-syntax #'(c d e)))) - (check-true (no-binding-overlap? (in-syntax #'(a b c)) '())) - (check-true (no-binding-overlap? '() (in-syntax #'(d e f)))))) - - -(define/guard (no-binding-conflicts? ids body-scopes) - (define analysis (current-source-code-analysis)) - (for/and ([x (in-list ids)]) - (define x* - (if analysis - (hash-ref (source-code-analysis-scopes-by-location analysis) (syntax-source-location x) x) - x)) - (free-identifier=? x* (datum->syntax body-scopes (syntax-e x))))) - - -(define-record-type parsed-binding-clause - (original bound-identifiers identifier-side right-hand-side referenced-identifiers)) + #`(~splicing-replacement (bindings.definition ... body ...) #:original #,this-syntax))) (define-syntax-class binding-clause - #:attributes (parsed) - (pattern (~and original [id:id rhs:expr]) - #:attr parsed - (parsed-binding-clause - #:original #'original - #:bound-identifiers (list #'id) - #:identifier-side #'id - #:right-hand-side #'rhs - #:referenced-identifiers (syntax-identifiers #'rhs))) - (pattern (~and original [(~and id-side (id:id ...)) rhs:expr]) - #:attr parsed - (parsed-binding-clause - #:original #'original - #:bound-identifiers (syntax->list #'(id ...)) - #:identifier-side #'id-side - #:right-hand-side #'rhs - #:referenced-identifiers (syntax-identifiers #'rhs)))) - - -(define (parsed-binding-clause-definition clause) - (define rhs (parsed-binding-clause-right-hand-side clause)) - (define id-side (parsed-binding-clause-identifier-side clause)) - (define definition - (match (parsed-binding-clause-bound-identifiers clause) - [(list id) - (syntax-parse rhs - #:literals (lambda λ) - [((~or lambda λ) (arg:formal ...) body ...) - #`(define (#,id (~@ (~? arg.kw) (~? [arg.name arg.default] arg.name)) ...) - body ...)] - [((~or lambda λ) (arg:formal ... . rest:identifier) body ...) - #`(define (#,id (~@ (~? arg.kw) (~? [arg.name arg.default] arg.name)) ... . rest) - body ...)] - [((~or lambda λ) args:identifier body ...) - #:with id* id - #`(define (id* . args) - body ...)] - [_ #`(define (~replacement #,id #:original #,id-side) #,rhs)])] - [_ #`(define-values #,id-side #,rhs)])) - #`(~replacement #,definition #:original #,(parsed-binding-clause-original clause))) - - -(define (binding-clause-depends-on? dependant dependency) - (define dependant-references (parsed-binding-clause-referenced-identifiers dependant)) - (define dependency-ids (parsed-binding-clause-bound-identifiers dependency)) - (not (no-binding-overlap? dependant-references dependency-ids))) - - -(define-record-type parsed-binding-graph (clauses dependencies)) - - -(define (let-binding-clause-dependencies clauses) - (for*/list ([(dependant i) (in-indexed (in-vector clauses))] - [(dependency j) (in-indexed (in-vector clauses))] - #:when (binding-clause-depends-on? dependant dependency)) - (entry i j))) - - -(define-record-type split-bindings (before-cycles cycles after-cycles changed?)) - - -(define/guard (let-binding-graph-split graph) - (define binding-count (vector-length (parsed-binding-graph-clauses graph))) - (define cycle-indices (graph-cycle-vertices (parsed-binding-graph-dependencies graph))) - (define changed? (not (equal? (length cycle-indices) binding-count))) - (guard (not (empty? cycle-indices)) #:else - (split-bindings - #:before-cycles (vector->list (parsed-binding-graph-clauses graph)) - #:cycles '() - #:after-cycles '() - #:changed? changed?)) - (define cycle-start-index (transduce cycle-indices #:into (nonempty-into-min))) - (define cycle-end-index (add1 (transduce cycle-indices #:into (nonempty-into-max)))) - (define before-cycles - (for/list ([i (in-range 0 cycle-start-index)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (define cycles - (for/list ([i (in-range cycle-start-index cycle-end-index)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (define after-cycles - (for/list ([i (in-range cycle-end-index binding-count)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (split-bindings - #:before-cycles before-cycles - #:cycles cycles - #:after-cycles after-cycles - #:changed? changed?)) - - -(define/guard (let*-binding-graph-split graph) - (define binding-count (vector-length (parsed-binding-graph-clauses graph))) - (define (referenced-by-earlier? i) - (define earliest-predecessor - (transduce (graph-predecessors (parsed-binding-graph-dependencies graph) i) #:into into-first)) - (match earliest-predecessor - [(present s) (<= s i)] - [_ #false])) - (define cycle-start-index-opt - (transduce (in-range 0 binding-count) - (filtering referenced-by-earlier?) - #:into into-first)) - (guard-match (present cycle-start-index) cycle-start-index-opt #:else - (split-bindings - #:before-cycles (vector->list (parsed-binding-graph-clauses graph)) - #:cycles '() - #:after-cycles '() - #:changed? (positive? binding-count))) - (define cycle-end-index - (add1 - (transduce (in-range (sub1 binding-count) -1 -1) - (filtering referenced-by-earlier?) - #:into nonempty-into-first))) - (define before-cycles - (for/list ([i (in-range 0 cycle-start-index)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (define cycles - (for/list ([i (in-range cycle-start-index cycle-end-index)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (define after-cycles - (for/list ([i (in-range cycle-end-index binding-count)]) - (vector-ref (parsed-binding-graph-clauses graph) i))) - (split-bindings - #:before-cycles before-cycles - #:cycles cycles - #:after-cycles after-cycles - #:changed? (or (not (empty? before-cycles)) (not (empty? after-cycles))))) - - -(define (split-bindings-fully-refactorable? split) - (and (empty? (split-bindings-cycles split)) - (empty? (split-bindings-after-cycles split)))) - - -(define (split-bindings-outer-ids split) - (for*/list ([before (in-list (split-bindings-before-cycles split))] - [id (in-list (parsed-binding-clause-bound-identifiers before))]) - id)) - - -(define (split-bindings-inner-ids split) - (for*/list ([after (in-list (split-bindings-after-cycles split))] - [id (in-list (parsed-binding-clause-bound-identifiers after))]) - id)) - - -(define (split-bindings-outer-definitions split) - (define/with-syntax (definition ...) - (for/list ([before (in-list (split-bindings-before-cycles split))]) - (parsed-binding-clause-definition before))) - #'(definition ...)) - + #:attributes ([id 1] rhs definition) + + (pattern [all-ids:id-list rhs:expr] + #:do [(log-resyntax-debug + "refactorable-let-expression: checking binding-clause not self shadowing: ~a" + this-syntax)] + #:when (for*/and ([rhs-free-id (in-free-id-set (syntax-free-identifiers (attribute rhs)))] + [id (in-list (attribute all-ids.id))]) + (log-resyntax-debug "refactorable-let-expression: checking identifier not shadowed: ~a" + rhs-free-id) + (identifier-binding-unchanged-in-context? rhs-free-id id)) + #:cut + #:with (id ...) (attribute all-ids.id) + #:with definition + (match (attribute id) + ['() #'rhs] + [(list only-id) + (syntax-parse (attribute rhs) + [(_:lambda-by-any-name (arg:formal ...) body ...) + #`(define (#,only-id (~@ . arg) ...) + body ...)] + [(_:lambda-by-any-name (arg:formal ...+ . tail-arg) body ...) + #`(define (#,only-id (~@ . arg) ... . tail-arg) + body ...)] + [(_:lambda-by-any-name tail-arg:identifier body ...) + #`(define (#,only-id . tail-arg) + body ...)] + [_ + #`(define (~replacement #,only-id #:original all-ids) rhs)])] + [_ #'(define-values all-ids rhs)]))) + + +(define-syntax-class id-list + #:attributes ([id 1]) + (pattern only-id:id #:with (id ...) (list (attribute only-id))) + (pattern (id ...))) + + +(define-syntax-class (binding-group #:nested? [nested #false]) + #:attributes ([id 1] [definition 1]) + (pattern (clause:binding-clause ...) + #:when (or (not nested) + (for/and ([rhs (in-list (attribute clause.rhs))] + [i (in-naturals)] + #:when #true + [ids (in-list (attribute clause.id))] + [j (in-naturals)] + #:when (< i j) + [id (in-list ids)] + #:when #true + [rhs-free-id (in-free-id-set (syntax-free-identifiers rhs))]) + (identifier-binding-unchanged-in-context? rhs-free-id id))) + #:cut + #:with (id ...) #'(clause.id ... ...) + #:with (definition ...) + #`(~splicing-replacement ((~replacement clause.definition #:original clause) ...) + #:original #,this-syntax))) -(define-syntax-class body-form - #:literals (define define-syntax define-values define-syntaxes) - #:attributes ([bound-id 1]) - (pattern (define id:id ~! _) #:with (bound-id ...) #'(id)) - (pattern (define header:function-header ~! _ ...) #:with (bound-id ...) #'(header.name)) - (pattern (define-syntax id:id ~! _) #:with (bound-id ...) #'(id)) - (pattern (define-syntax header:function-header ~! _ ...) #:with (bound-id ...) #'(header.name)) - (pattern (define-values ~! (bound-id:id ...) _)) - (pattern (define-syntaxes ~! (bound-id:id ...) _)) - (pattern _ #:with (bound-id ...) #'())) +(define (identifier-binding-unchanged-in-context? id context) + (define add-context (make-syntax-delta-introducer context #false)) + (free-identifier=? id (add-context id))) -(define-splicing-syntax-class body-forms - #:attributes (scopes [bound-id 1] [formatted 1]) - (pattern (~seq form:body-form ...) - #:with scopes - (or (for/or ([b (in-list (reverse (attribute form)))]) - (define analysis (current-source-code-analysis)) - (and analysis - (hash-ref (source-code-analysis-scopes-by-location analysis) - (syntax-source-location b) - #false))) - (and (pair? (attribute form)) (last (attribute form)))) - #:with (bound-id ...) #'(form.bound-id ... ...) - #:with (formatted ...) #'(form ...))) +(define (identifier-has-exact-binding-in-context? id context) + (and (identifier-binding (identifier-in-context id context) 0 #false #true) #true)) -(module+ test - (test-case "body-form" - (define (parse stx) (syntax-parse stx [form:body-form (syntax->datum #'(form.bound-id ...))])) - (check-equal? (parse #'(define a 42)) (list 'a)) - (check-equal? (parse #'(define (f a b c) 42)) (list 'f)) - (check-equal? (parse #'(define (((f a) b) c) 42)) (list 'f)) - (check-equal? (parse #'(define-syntax a 42)) (list 'a)) - (check-equal? (parse #'(define-syntax (f a b c) 42)) (list 'f)) - (check-equal? (parse #'(define-syntax (((f a) b) c) 42)) (list 'f)) - (check-equal? (parse #'(define-values (a b c) 42)) (list 'a 'b 'c)) - (check-equal? (parse #'(define-syntaxes (a b c) 42)) (list 'a 'b 'c)) - (check-equal? (parse #'(void)) '()))) +(define (identifier-in-context id context) + (datum->syntax context (syntax-e id) id id)) diff --git a/main.rkt b/main.rkt index 27b1ecf..415f844 100644 --- a/main.rkt +++ b/main.rkt @@ -56,7 +56,7 @@ absent)]) (guarded-block (guard-match (present replacement) - (refactoring-rule-refactor rule syntax #:analysis analysis) + (refactoring-rule-refactor rule syntax) #:else absent) (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else (log-resyntax-warning diff --git a/private/linemap.rkt b/private/linemap.rkt index fc3a665..b4d3f76 100644 --- a/private/linemap.rkt +++ b/private/linemap.rkt @@ -97,8 +97,17 @@ (define (syntax-line-range stx #:linemap map) - (define end-line (linemap-position-to-line map (+ (syntax-position stx) (syntax-span stx)))) - (closed-range (syntax-line stx) end-line #:comparator natural<=>)) + (define first-line (syntax-line stx)) + (define last-line (linemap-position-to-line map (+ (syntax-position stx) (syntax-span stx)))) + (unless (<= first-line last-line) + (raise-arguments-error 'syntax-line-range + "syntax object's last line number is before its first line number" + "syntax" stx + "first line" first-line + "last line" last-line + "position" (syntax-position stx) + "span" (syntax-span stx))) + (closed-range first-line last-line #:comparator natural<=>)) (module+ test diff --git a/private/source.rkt b/private/source.rkt index 8f60d45..5062199 100644 --- a/private/source.rkt +++ b/private/source.rkt @@ -21,8 +21,6 @@ [source-code-analysis? predicate/c] [source-code-analysis-code (-> source-code-analysis? source?)] [source-code-analysis-visited-forms (-> source-code-analysis? (listof syntax?))] - [source-code-analysis-scopes-by-location - (-> source-code-analysis? (hash/c source-location? syntax? #:immutable #true))] [syntax-source-location (-> syntax? source-location?)] [with-input-from-source (-> source? (-> any) any)])) @@ -38,11 +36,13 @@ rebellion/base/range rebellion/collection/list rebellion/collection/range-set + rebellion/collection/vector/builder rebellion/streaming/reducer rebellion/streaming/transducer rebellion/type/record resyntax/private/linemap - syntax/modread) + syntax/modread + syntax/parse) ;@---------------------------------------------------------------------------------------------------- @@ -59,18 +59,7 @@ #:guard (λ (contents _) (string->immutable-string contents))) -;; source-code-analysis has fields: -;; * code: source, the input of the analysis -;; * visited-forms: (Listof Syntax), sorted by source location, containing -;; forms visited by the expander, with scopes put on them by expansion -;; steps in the surrounding context, but not yet expanded themselves -;; * scopes-by-location: (ImmHashOf source-location Syntax), containing -;; syntax objects that have the scopes from their surrounding context -;; For example, in `(let ([x a]) b)`, the expander expands it to -;; `(let-values ([(x) a]) b)` and adds letX-renames scopes to `x` and `b`. -;; The `scopes-by-location` table contains the versions of `x` and `b` -;; with those scopes. -(define-record-type source-code-analysis (code visited-forms scopes-by-location)) +(define-record-type source-code-analysis (code visited-forms)) (define-record-type source-location (source line column position span)) @@ -108,53 +97,67 @@ (define program-stx (source-read-syntax code)) (define program-source-name (syntax-source program-stx)) (define current-expand-observe (dynamic-require ''#%expobs 'current-expand-observe)) - (define visits-by-location (make-hash)) - (define others-by-location (make-hash)) - - (define (add-original-location! hsh stx) - (when (and (syntax? stx) - (syntax-original? stx) - ;; Some macros are able to bend hygiene and syntax properties in such a way that they - ;; introduce syntax objects into the program that are syntax-original?, but from a - ;; different file than the one being expanded. So in addition to checking for - ;; originality, we also check that they come from the same source as the main program - ;; syntax object. The (open ...) clause of the define-signature macro bends hygiene - ;; in this way, and is what originally motivated the addition of this check. - (equal? (syntax-source stx) program-source-name) - (range-set-encloses? lines (syntax-line-range stx #:linemap code-linemap))) - (define loc (syntax-source-location stx)) - (unless (hash-has-key? hsh loc) - (hash-set! hsh loc stx)))) + (define original-visits (make-vector-builder)) + (define expanded-originals-by-location (make-hash)) + + (define (add-all-original-subforms! stx) + (when (resyntax-should-analyze-syntax? stx) + (hash-set! expanded-originals-by-location (syntax-source-location stx) stx)) + (syntax-parse stx + [(subform ...) (for-each add-all-original-subforms! (attribute subform))] + [(subform ...+ . tail-form) + (for-each add-all-original-subforms! (attribute subform)) + (add-all-original-subforms! #'tail-form)] + [_ (void)])) + + (define (resyntax-should-analyze-syntax? stx) + (and (syntax-original? stx) + ;; Some macros are able to bend hygiene and syntax properties in such a way that they + ;; introduce syntax objects into the program that are syntax-original?, but from a + ;; different file than the one being expanded. So in addition to checking for + ;; originality, we also check that they come from the same source as the main program + ;; syntax object. The (open ...) clause of the define-signature macro bends hygiene + ;; in this way, and is what originally motivated the addition of this check. + (equal? (syntax-source stx) program-source-name) + (range-set-encloses? lines (syntax-line-range stx #:linemap code-linemap)))) (define/match (observe-event! sig val) - [('visit val) - (add-original-location! visits-by-location val)] - ;; For more information on `letX-renames`, see the `make-let-values-form` - ;; function in the Racket Expander where it logs `letX-renames` events: - ;; https://github.com/racket/racket/blob/b4a85f54c20cc246d521a4cc7ea4d8c2b52a7e59/racket/src/expander/expand/expr.rkt#L248 - [('letX-renames (list-rest trans-idss _ val-idss _)) - ;; When the expander adds scopes to `let-syntax`, it uses `trans-idss`. - (for* ([trans-ids (in-list trans-idss)] - [trans-id (in-list trans-ids)]) - (add-original-location! others-by-location trans-id)) - ;; When the expander adds scopes to `let-values`, it uses `val-idss`. - (for* ([val-ids (in-list val-idss)] - [val-id (in-list val-ids)]) - (add-original-location! others-by-location val-id))] + [('visit (? syntax? visited)) + (when (resyntax-should-analyze-syntax? visited) + (vector-builder-add original-visits visited) + (add-all-original-subforms! visited))] [(_ _) (void)]) + + (define expanded + (parameterize ([current-expand-observe observe-event!]) + (expand program-stx))) + (add-all-original-subforms! expanded) + + (define (enrich stx) + (define new-context + (or (hash-ref expanded-originals-by-location (syntax-source-location stx) #false) stx)) + (syntax-parse stx + [(subform ...) + (datum->syntax new-context + (map enrich (attribute subform)) + new-context + new-context)] + [(subform ...+ . tail-form) + (datum->syntax new-context + (append (map enrich (attribute subform)) (enrich #'tail-form)) + new-context + new-context)] + [_ new-context])) + - (parameterize ([current-expand-observe observe-event!]) - (expand program-stx)) - (define scopes-by-location - (hash-union (hash) visits-by-location others-by-location - #:combine (λ (a b) a))) (define visited - (transduce (in-hash-pairs visits-by-location) - (sorting syntax-source-location<=> #:key car) - #:into (reducer-map into-list #:domain cdr))) - (source-code-analysis #:code code - #:visited-forms visited - #:scopes-by-location scopes-by-location))) + (transduce (build-vector original-visits) + (deduplicating #:key syntax-source-location) + (mapping enrich) + (sorting syntax-source-location<=> #:key syntax-source-location) + #:into into-list)) + + (source-code-analysis #:code code #:visited-forms visited))) (define (syntax-source-location stx) diff --git a/refactoring-rule.rkt b/refactoring-rule.rkt index 9d69863..18bd183 100644 --- a/refactoring-rule.rkt +++ b/refactoring-rule.rkt @@ -9,16 +9,13 @@ define-definition-context-refactoring-rule (contract-out [refactoring-rule? predicate/c] - [refactoring-rule-description (-> refactoring-rule? immutable-string?)] - [current-source-code-analysis (-> (or/c source-code-analysis? #false))])) + [refactoring-rule-description (-> refactoring-rule? immutable-string?)])) (module+ private (provide (contract-out - [refactoring-rule-refactor - (-> refactoring-rule? syntax? #:analysis source-code-analysis? - (option/c syntax-replacement?))]))) + [refactoring-rule-refactor (-> refactoring-rule? syntax? (option/c syntax-replacement?))]))) (require (for-syntax racket/base @@ -38,15 +35,12 @@ ;@---------------------------------------------------------------------------------------------------- -(define current-source-code-analysis (make-parameter #false #false 'current-source-code-analysis)) - - (define-object-type refactoring-rule (transformer description) #:omit-root-binding #:constructor-name constructor:refactoring-rule) -(define (refactoring-rule-refactor rule syntax #:analysis analysis) +(define (refactoring-rule-refactor rule syntax) ;; Before refactoring the input syntax, we do two things: create a new scope and add it, and ;; traverse the syntax object making a note of each subform's original neighbors. Combined, @@ -58,7 +52,7 @@ (define prepared-syntax (rule-introduction-scope (syntax-mark-original-neighbors syntax))) (option-map - ((refactoring-rule-transformer rule) prepared-syntax analysis) + ((refactoring-rule-transformer rule) prepared-syntax) (λ (new-syntax) (syntax-replacement #:original-syntax syntax @@ -79,12 +73,11 @@ #:name 'id #:description (string->immutable-string description.c) #:transformer - (λ (stx analysis) - (parameterize ([current-source-code-analysis analysis]) - (syntax-parse stx - (~@ . parse-option) ... - [pattern (~@ . pattern-directive) ... (present #'replacement)] - [_ absent])))))) + (λ (stx) + (syntax-parse stx + (~@ . parse-option) ... + [pattern (~@ . pattern-directive) ... (present #'replacement)] + [_ absent]))))) (define-syntax-parse-rule