diff --git a/base.rkt b/base.rkt index 1d14d28..bc476e2 100644 --- a/base.rkt +++ b/base.rkt @@ -8,6 +8,7 @@ ~replacement ~splicing-replacement ~focus-replacement-on + resyntax-suppress define-refactoring-suite define-refactoring-rule define-definition-context-refactoring-rule @@ -23,7 +24,8 @@ #:name (or/c interned-symbol? #false)) refactoring-suite?)] [refactoring-suite-rules (-> refactoring-suite? (listof refactoring-rule?))] - [refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))])) + [refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))] + [syntax-suppresses-rule? (-> syntax? symbol? boolean?)])) (module+ private @@ -108,6 +110,70 @@ [(_ new-stx) (syntax-property #'new-stx 'focus-replacement-on #true)])) +;; Suppression support +(define-syntax (resyntax-suppress stx) + (syntax-parse stx + [(_ rule-id:id body:expr ...+) + (define rule-symbol (syntax-e #'rule-id)) + ;; Helper to add suppression property to syntax with preservation + (define (add-suppression s) + (define existing (syntax-property s 'resyntax-suppressed-rules)) + (syntax-property s 'resyntax-suppressed-rules + (cons rule-symbol (or existing '())) + #true)) ; #true means preserve during expansion + ;; Recursively add suppression to all syntax objects in the tree + (define (propagate-suppression s) + (cond + [(syntax? s) + (define updated (add-suppression s)) + (define datum (syntax-e updated)) + (cond + [(pair? datum) + (datum->syntax updated + (cons (propagate-suppression (car datum)) + (propagate-suppression (cdr datum))) + updated + updated)] + [(vector? datum) + (datum->syntax updated + (for/vector ([elem (in-vector datum)]) + (propagate-suppression elem)) + updated + updated)] + [(box? datum) + (datum->syntax updated + (box (propagate-suppression (unbox datum))) + updated + updated)] + [(prefab-struct-key datum) + (datum->syntax updated + (apply make-prefab-struct + (prefab-struct-key datum) + (map propagate-suppression (cdr (vector->list (struct->vector datum))))) + updated + updated)] + [else updated])] + [(pair? s) + (cons (propagate-suppression (car s)) + (propagate-suppression (cdr s)))] + [(vector? s) + (for/vector ([elem (in-vector s)]) + (propagate-suppression elem))] + [(box? s) + (box (propagate-suppression (unbox s)))] + [else s])) + ;; Apply to all body expressions + (define suppressed-bodies + (for/list ([b (in-list (attribute body))]) + (propagate-suppression b))) + ;; Don't add suppression to the begin form itself, just return it + #`(begin #,@suppressed-bodies)])) + +(define (syntax-suppresses-rule? stx rule-name) + (define suppressed-rules (syntax-property stx 'resyntax-suppressed-rules)) + (and suppressed-rules (member rule-name suppressed-rules) #t)) + + (define-object-type refactoring-rule (transformer description uses-universal-tagged-syntax? analyzers) #:omit-root-binding #:constructor-name constructor:refactoring-rule) diff --git a/main.rkt b/main.rkt index a9db4eb..50f0dd4 100644 --- a/main.rkt +++ b/main.rkt @@ -374,56 +374,60 @@ (define (refactoring-rules-refactor rules syntax #:comments comments #:analysis analysis) (define (refactor rule) - (with-handlers - ([exn:fail? - (λ (e) - (log-resyntax-error "~a: refactoring attempt failed\n syntax:\n ~a\n cause:\n~a" - (object-name rule) - syntax - (string-indent (exn-message e) #:amount 3)) - absent)]) - (guarded-block - (guard-match (present replacement) - (parameterize ([current-namespace (source-code-analysis-namespace analysis)]) - (refactoring-rule-refactor rule syntax (source-code-analysis-code analysis))) - #:else absent) - (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else - (define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement)) - (define orig-stx (syntax-replacement-original-syntax replacement)) - (define intro (syntax-replacement-introduction-scope replacement)) - (log-resyntax-warning - (string-append - "~a: suggestion discarded because it introduces identifiers with incorrect bindings\n" - " incorrect identifiers: ~a\n" - " bindings in original context: ~a\n" - " bindings in syntax replacement: ~a\n" - " replaced syntax: ~a") - (object-name rule) - bad-ids - (for/list ([id (in-list bad-ids)]) - (identifier-binding (datum->syntax orig-stx (syntax->datum id)))) - (for/list ([id (in-list bad-ids)]) - (identifier-binding (intro id 'remove))) - orig-stx) - absent) - (guard (syntax-replacement-preserves-comments? replacement comments) #:else - (log-resyntax-warning - (string-append "~a: suggestion discarded because it does not preserve all comments\n" - " dropped comment locations: ~v\n" - " original syntax:\n" - " ~v\n" - " replacement syntax:\n" - " ~v") - (object-name rule) - (syntax-replacement-dropped-comment-locations replacement comments) - (syntax-replacement-original-syntax replacement) - (syntax-replacement-new-syntax replacement)) - absent) - (present - (refactoring-result - #:rule-name (object-name rule) - #:message (refactoring-rule-description rule) - #:syntax-replacement replacement))))) + (define rule-name (object-name rule)) + ;; Check if this rule is suppressed for this syntax + (if (syntax-suppresses-rule? syntax rule-name) + absent + (with-handlers + ([exn:fail? + (λ (e) + (log-resyntax-error "~a: refactoring attempt failed\n syntax:\n ~a\n cause:\n~a" + rule-name + syntax + (string-indent (exn-message e) #:amount 3)) + absent)]) + (guarded-block + (guard-match (present replacement) + (parameterize ([current-namespace (source-code-analysis-namespace analysis)]) + (refactoring-rule-refactor rule syntax (source-code-analysis-code analysis))) + #:else absent) + (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else + (define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement)) + (define orig-stx (syntax-replacement-original-syntax replacement)) + (define intro (syntax-replacement-introduction-scope replacement)) + (log-resyntax-warning + (string-append + "~a: suggestion discarded because it introduces identifiers with incorrect bindings\n" + " incorrect identifiers: ~a\n" + " bindings in original context: ~a\n" + " bindings in syntax replacement: ~a\n" + " replaced syntax: ~a") + rule-name + bad-ids + (for/list ([id (in-list bad-ids)]) + (identifier-binding (datum->syntax orig-stx (syntax->datum id)))) + (for/list ([id (in-list bad-ids)]) + (identifier-binding (intro id 'remove))) + orig-stx) + absent) + (guard (syntax-replacement-preserves-comments? replacement comments) #:else + (log-resyntax-warning + (string-append "~a: suggestion discarded because it does not preserve all comments\n" + " dropped comment locations: ~v\n" + " original syntax:\n" + " ~v\n" + " replacement syntax:\n" + " ~v") + rule-name + (syntax-replacement-dropped-comment-locations replacement comments) + (syntax-replacement-original-syntax replacement) + (syntax-replacement-new-syntax replacement)) + absent) + (present + (refactoring-result + #:rule-name rule-name + #:message (refactoring-rule-description rule) + #:syntax-replacement replacement)))))) (falsey->option (for*/first ([rule (in-list rules)] diff --git a/main.scrbl b/main.scrbl index d1e3c18..1d60f04 100644 --- a/main.scrbl +++ b/main.scrbl @@ -429,6 +429,38 @@ guide Resyntax's internal comment preservation system when the default behavior because such rules often touch only a small series of forms in a much larger definition context.} +@subsection{Suppressing Specific Suggestions} + +@defform[(resyntax-suppress rule-id body ...+)]{ + Suppresses the application of a specific @tech{refactoring rule} to the code in @racket[body]. The + @racket[rule-id] must be the name of a refactoring rule. This form is useful when a refactoring + suggestion makes sense generally, but is unhelpful in a specific context. + + For example, suppose you have code that maintains visual symmetry by using similar comparisons with + zero: + + @(racketblock + (and (= (- x y) 0) + (> (- x y) 0) + (< (- x y) 0))) + + While Resyntax would normally suggest simplifying @racket[(> (- x y) 0)] to @racket[(> x y)], doing + so would break the visual pattern. You can suppress this specific suggestion while still allowing + other refactorings: + + @(racketblock + (resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison + (and (= (- x y) 0) + (> (- x y) 0) + (< (- x y) 0)))) + + The suppression applies to all code within the @racket[body] forms. Multiple expressions can be + suppressed together, and suppression works with nested forms. + + Note that @racket[resyntax-suppress] must be @racket[require]d from @racket[resyntax/base] before + use.} + + @subsection{Resyntax's Default Rules} @defmodule[resyntax/default-recommendations] diff --git a/test/suppression-comparison-test.rkt b/test/suppression-comparison-test.rkt new file mode 100644 index 0000000..b9cd4d2 --- /dev/null +++ b/test/suppression-comparison-test.rkt @@ -0,0 +1,35 @@ +#lang resyntax/test + + +require: resyntax/default-recommendations comparison-shortcuts + + +header: +------------------------------ +#lang racket/base +(require resyntax/base) +(define x 1) +(define y 2) +------------------------------ + + +no-change-test: "suppressing comparison rule prevents refactoring" +------------------------------ +(resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison + (> (- x y) 0)) +------------------------------ + + +test: "unsuppressed comparison is refactored" +- (> (- x y) 0) +- (> x y) + + +no-change-test: "specific comparison in symmetrical context can be suppressed" +------------------------------ +;; Example from the issue - maintaining visual symmetry +(resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison + (and (= (- x y) 0) + (> (- x y) 0) + (< (- x y) 0))) +------------------------------ diff --git a/test/suppression-test.rkt b/test/suppression-test.rkt new file mode 100644 index 0000000..87d2500 --- /dev/null +++ b/test/suppression-test.rkt @@ -0,0 +1,68 @@ +#lang resyntax/test + + +require: resyntax/default-recommendations boolean-shortcuts + + +header: +------------------------------ +#lang racket/base +(require resyntax/base) +------------------------------ + + +no-change-test: "suppressing a rule prevents its application" +------------------------------ +(resyntax-suppress nested-and-to-flat-and + (and 1 (and 2 3))) +------------------------------ + + +no-change-test: "suppressed nested or is not refactored" +------------------------------ +(resyntax-suppress nested-or-to-flat-or + (or 1 (or 2 3))) +------------------------------ + + +test: "unsuppressed nested or is refactored normally" +- (or 1 (or 2 3)) +- (or 1 2 3) + + +test: "suppression is specific to the rule name" +------------------------------ +(resyntax-suppress nested-or-to-flat-or + (and 1 (and 2 3))) +============================== +(resyntax-suppress nested-or-to-flat-or + (and 1 2 3)) +------------------------------ + + +no-change-test: "multiple expressions can be suppressed in one form" +------------------------------ +(resyntax-suppress nested-and-to-flat-and + (and 1 (and 2 3)) + (and 4 (and 5 6))) +------------------------------ + + +no-change-test: "suppression works with nested forms" +------------------------------ +(resyntax-suppress nested-and-to-flat-and + (define x (and 1 (and 2 3))) + (define y (and 4 (and 5 6)))) +------------------------------ + + +test: "suppression outside a form doesn't affect it" +------------------------------ +(resyntax-suppress nested-and-to-flat-and + (define x 1)) +(and 1 (and 2 3)) +============================== +(resyntax-suppress nested-and-to-flat-and + (define x 1)) +(and 1 2 3) +------------------------------