├── .github ├── ISSUE_TEMPLATE │ └── new-lint-request.md └── workflows │ └── main.yml ├── .gitignore ├── CONTRIBUTING.md ├── GITHUB_APP_PRIVACY_POLICY.md ├── LICENSE ├── README.md ├── base.rkt ├── cli.rkt ├── default-recommendations.rkt ├── default-recommendations ├── boolean-shortcuts-test.rkt ├── boolean-shortcuts.rkt ├── class-shortcuts-test.rkt ├── class-shortcuts.rkt ├── comparison-shortcuts-test.rkt ├── comparison-shortcuts.rkt ├── conditional-shortcuts-test.rkt ├── conditional-shortcuts.rkt ├── console-io-suggestions-test.rkt ├── console-io-suggestions.rkt ├── contract-shortcuts-test.rkt ├── contract-shortcuts.rkt ├── definition-shortcuts-test.rkt ├── definition-shortcuts.rkt ├── file-io-suggestions-test.rkt ├── file-io-suggestions.rkt ├── for-loop-shortcuts-test.rkt ├── for-loop-shortcuts.rkt ├── formatting-preservation-test.rkt ├── function-definition-shortcuts-test.rkt ├── function-definition-shortcuts.rkt ├── function-shortcuts-test.rkt ├── function-shortcuts.rkt ├── gap-preservation-test.rkt ├── gap-preservation.rkt ├── hash-shortcuts-test.rkt ├── hash-shortcuts.rkt ├── legacy-contract-migrations-test.rkt ├── legacy-contract-migrations.rkt ├── legacy-struct-migrations-test.rkt ├── legacy-struct-migrations.rkt ├── legacy-syntax-migrations-test.rkt ├── legacy-syntax-migrations.rkt ├── let-binding-suggestions-comment-test.rkt ├── let-binding-suggestions-function-shortcuts-test.rkt ├── let-binding-suggestions-nesting-test.rkt ├── let-binding-suggestions-test.rkt ├── let-binding-suggestions.rkt ├── list-shortcuts-test.rkt ├── list-shortcuts.rkt ├── match-shortcuts-test.rkt ├── match-shortcuts.rkt ├── miscellaneous-suggestions.rkt ├── numeric-shortcuts-test.rkt ├── numeric-shortcuts.rkt ├── private │ ├── boolean.rkt │ ├── definition-context.rkt │ ├── exception.rkt │ ├── lambda-by-any-name.rkt │ ├── let-binding.rkt │ ├── literal-constant.rkt │ ├── metafunction.rkt │ ├── pure-expression.rkt │ ├── syntax-equivalence.rkt │ ├── syntax-identifier-sets.rkt │ ├── syntax-lines.rkt │ └── syntax-tree.rkt ├── require-and-provide-suggestions-test.rkt ├── require-and-provide-suggestions.rkt ├── shadowed-output-test.rkt ├── string-shortcuts-test.rkt ├── string-shortcuts.rkt ├── syntax-parse-shortcuts-test.rkt ├── syntax-parse-shortcuts.rkt ├── syntax-rules-shortcuts-test.rkt ├── syntax-rules-shortcuts.rkt ├── syntax-shortcuts-test.rkt ├── syntax-shortcuts.rkt ├── unused-binding-suggestions-test.rkt ├── unused-binding-suggestions.rkt └── windows-newline-test.rkt ├── info.rkt ├── main.rkt ├── main.scrbl ├── private ├── code-snippet.rkt ├── comment-reader.rkt ├── commit.rkt ├── file-group.rkt ├── fully-expanded-syntax.rkt ├── git.rkt ├── github.rkt ├── identifier-naming.rkt ├── limiting.rkt ├── line-replacement.rkt ├── linemap.rkt ├── logger.rkt ├── more-syntax-parse-classes.rkt ├── refactoring-result.rkt ├── run-command.rkt ├── scribble-evaluator-factory.rkt ├── source.rkt ├── string-indent.rkt ├── string-replacement.rkt ├── syntax-neighbors.rkt ├── syntax-range.rkt ├── syntax-replacement.rkt └── syntax-traversal.rkt ├── test.rkt └── test └── private ├── grammar.rkt ├── rackunit.rkt ├── statement.rkt └── tokenizer.rkt /.github/ISSUE_TEMPLATE/new-lint-request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: New lint request 3 | about: Suggest a new Resyntax refactoring rule 4 | title: '' 5 | labels: new lint 6 | assignees: '' 7 | 8 | --- 9 | 10 | _Describe the lint you'd like to see added to Resyntax. Include example code in the test case below. If applicable, include links to files where this lint would help._ 11 | 12 | ```scheme 13 | #lang resyntax/test 14 | 15 | test: "original code should be refactorable to new code" 16 | -------------------- 17 | #lang racket 18 | ;; Put the original code here 19 | -------------------- 20 | -------------------- 21 | #lang racket 22 | ;; Put the code you'd like Resyntax to generate here 23 | -------------------- 24 | ``` 25 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | ci: 7 | name: "Build and Test" 8 | runs-on: ubuntu-latest 9 | steps: 10 | - uses: actions/checkout@master 11 | - uses: Bogdanp/setup-racket@v1.5 12 | with: 13 | version: stable 14 | - run: raco pkg install --batch --auto --link --name resyntax 15 | - run: raco test --package resyntax 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | doc/ 3 | *~ 4 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing / development guidelines 2 | 3 | To install locally for development, run `raco pkg install --auto --link 4 | --installation`. 5 | 6 | To run the tests, use `raco test -p resyntax`. 7 | 8 | It is **recommended** to use either [DrRacket][dr] or [racket-langserver][rls] 9 | with the latest [Racket][rkt] (not `racket-minimal`). 10 | 11 | [dr]: https://docs.racket-lang.org/drracket/ 12 | [rls]: https://pkgs.racket-lang.org/package/racket-langserver 13 | [rkt]: https://download.racket-lang.org/ 14 | -------------------------------------------------------------------------------- /GITHUB_APP_PRIVACY_POLICY.md: -------------------------------------------------------------------------------- 1 | # Privacy Policy 2 | 3 | Last updated: October 12, 2024 4 | 5 | The Resyntax CI GitHub App does not collect, use, store, or transmit any personal data. 6 | 7 | ## Contact Us 8 | 9 | If you have any questions about this Privacy Policy, you can contact us: 10 | 11 | - By email: jackhfirth@gmail.com 12 | - By visiting this page on our website: https://github.com/jackfirth/resyntax/ 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # resyntax [![CI Status][ci-status-badge]][ci-status] [![Documentation][docs-badge]][docs] 2 | 3 | A refactoring tool for Racket built on top of `syntax-parse`. 4 | 5 | [ci-status]: https://github.com/jackfirth/resyntax/actions 6 | [ci-status-badge]: https://github.com/jackfirth/resyntax/workflows/CI/badge.svg 7 | [docs]: https://docs.racket-lang.org/resyntax/index.html 8 | [docs-badge]: https://img.shields.io/badge/docs-published-blue.svg 9 | 10 | ## Quickstart 11 | 12 | Use the Racket package manager to install in the installation scope. 13 | ``` 14 | raco pkg install --installation resyntax 15 | ``` 16 | The `--installation` flag (shorthand for `--scope installation`) installs packages for all users of a Racket installation and ensures `resyntax` is in your `$PATH`. 17 | 18 | e.g. 19 | ``` 20 | % resyntax analyze --file coroutines-example.rkt 21 | resyntax: --- analyzing code --- 22 | resyntax: --- displaying results --- 23 | % 24 | ``` 25 | 26 | See the documentation for more details on how to use `resyntax`. 27 | 28 | ## Examples 29 | 30 | Resyntax integrates with GitHub in two ways: an _analyzer_ GitHub action that reviews pull requests, and an _autofixer_ GitHub action that periodically creates pull requests cleaning up a repository. You can find reviews the Resyntax analyzer has left on GitHub pull requests "in the wild" using [this search](https://github.com/search?q=%22Resyntax%20analyzed%22%20%22added%20suggestions%22%20in%3Acomments%20is%3Apr%20sort%3Aupdated%20&type=pullrequests). To find pull requests created by the autofixer, use [this search](https://github.com/search?q=author%3Aapp%2Fresyntax-ci&type=pullrequests). 31 | -------------------------------------------------------------------------------- /default-recommendations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (all-from-out resyntax/default-recommendations/boolean-shortcuts 9 | resyntax/default-recommendations/class-shortcuts 10 | resyntax/default-recommendations/comparison-shortcuts 11 | resyntax/default-recommendations/conditional-shortcuts 12 | resyntax/default-recommendations/console-io-suggestions 13 | resyntax/default-recommendations/contract-shortcuts 14 | resyntax/default-recommendations/definition-shortcuts 15 | resyntax/default-recommendations/file-io-suggestions 16 | resyntax/default-recommendations/for-loop-shortcuts 17 | resyntax/default-recommendations/function-definition-shortcuts 18 | resyntax/default-recommendations/function-shortcuts 19 | resyntax/default-recommendations/hash-shortcuts 20 | resyntax/default-recommendations/legacy-contract-migrations 21 | resyntax/default-recommendations/legacy-struct-migrations 22 | resyntax/default-recommendations/legacy-syntax-migrations 23 | resyntax/default-recommendations/let-binding-suggestions 24 | resyntax/default-recommendations/list-shortcuts 25 | resyntax/default-recommendations/match-shortcuts 26 | resyntax/default-recommendations/miscellaneous-suggestions 27 | resyntax/default-recommendations/numeric-shortcuts 28 | resyntax/default-recommendations/require-and-provide-suggestions 29 | resyntax/default-recommendations/string-shortcuts 30 | resyntax/default-recommendations/syntax-shortcuts 31 | resyntax/default-recommendations/syntax-parse-shortcuts 32 | resyntax/default-recommendations/syntax-rules-shortcuts 33 | resyntax/default-recommendations/unused-binding-suggestions) 34 | (contract-out 35 | [default-recommendations refactoring-suite?])) 36 | 37 | 38 | (require rebellion/private/static-name 39 | resyntax/base 40 | resyntax/default-recommendations/boolean-shortcuts 41 | resyntax/default-recommendations/class-shortcuts 42 | resyntax/default-recommendations/comparison-shortcuts 43 | resyntax/default-recommendations/conditional-shortcuts 44 | resyntax/default-recommendations/console-io-suggestions 45 | resyntax/default-recommendations/contract-shortcuts 46 | resyntax/default-recommendations/definition-shortcuts 47 | resyntax/default-recommendations/file-io-suggestions 48 | resyntax/default-recommendations/for-loop-shortcuts 49 | resyntax/default-recommendations/function-definition-shortcuts 50 | resyntax/default-recommendations/function-shortcuts 51 | resyntax/default-recommendations/hash-shortcuts 52 | resyntax/default-recommendations/legacy-contract-migrations 53 | resyntax/default-recommendations/legacy-struct-migrations 54 | resyntax/default-recommendations/legacy-syntax-migrations 55 | resyntax/default-recommendations/let-binding-suggestions 56 | resyntax/default-recommendations/list-shortcuts 57 | resyntax/default-recommendations/match-shortcuts 58 | resyntax/default-recommendations/miscellaneous-suggestions 59 | resyntax/default-recommendations/numeric-shortcuts 60 | resyntax/default-recommendations/require-and-provide-suggestions 61 | resyntax/default-recommendations/string-shortcuts 62 | resyntax/default-recommendations/syntax-parse-shortcuts 63 | resyntax/default-recommendations/syntax-rules-shortcuts 64 | resyntax/default-recommendations/syntax-shortcuts 65 | resyntax/default-recommendations/unused-binding-suggestions) 66 | 67 | 68 | ;@---------------------------------------------------------------------------------------------------- 69 | 70 | 71 | (define-refactoring-suite default-recommendations 72 | #:suites (boolean-shortcuts 73 | class-shortcuts 74 | comparison-shortcuts 75 | conditional-shortcuts 76 | console-io-suggestions 77 | contract-shortcuts 78 | definition-shortcuts 79 | file-io-suggestions 80 | for-loop-shortcuts 81 | function-definition-shortcuts 82 | function-shortcuts 83 | hash-shortcuts 84 | legacy-contract-migrations 85 | 86 | ;; Excluded for lots of reasons. See the following github issues: 87 | ;; - jackfirth/resyntax#47 88 | ;; - sorawee/fmt#29 89 | ;; - sorawee/fmt#60 90 | ;; - sorawee/fmt#65 91 | ;; legacy-struct-migrations 92 | 93 | legacy-syntax-migrations 94 | let-binding-suggestions 95 | list-shortcuts 96 | match-shortcuts 97 | miscellaneous-suggestions 98 | numeric-shortcuts 99 | require-and-provide-suggestions 100 | string-shortcuts 101 | syntax-shortcuts 102 | syntax-parse-shortcuts 103 | syntax-rules-shortcuts 104 | 105 | ;; Excluded because of https://github.com/jackfirth/resyntax/issues/410 106 | ;; unused-binding-suggestions 107 | 108 | )) 109 | -------------------------------------------------------------------------------- /default-recommendations/boolean-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations boolean-shortcuts 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "nested ors can be flattened" 12 | - (or 1 2 (or 3 4)) 13 | - (or 1 2 3 4) 14 | 15 | 16 | test: "flat ors can't be flattened" 17 | - (or 1 2 3) 18 | 19 | 20 | test: "multiple nested ors can be flattened at once" 21 | - (or (or 1 2) (or 3 4) (or 5 6)) 22 | - (or 1 2 3 4 5 6) 23 | 24 | 25 | test: "deeply nested ors can be flattened in one pass" 26 | - (or 1 (or 2 (or 3 (or 4 5 6)))) 27 | - (or 1 2 3 4 5 6) 28 | 29 | 30 | test: "multiline nested ors can't be flattened" 31 | ------------------------------ 32 | (or 1 33 | (or 2 3)) 34 | ------------------------------ 35 | 36 | 37 | test: "nested ands can be flattened" 38 | - (and 1 2 (and 3 4)) 39 | - (and 1 2 3 4) 40 | 41 | 42 | test: "flat ands can't be flattened" 43 | - (and 1 2 3) 44 | 45 | 46 | test: "multiple nested ands can be flattened at once" 47 | - (and (and 1 2) (and 3 4) (and 5 6)) 48 | - (and 1 2 3 4 5 6) 49 | 50 | 51 | test: "deeply nested ands can be flattened in one pass" 52 | - (and 1 (and 2 (and 3 (and 4 5 6)))) 53 | - (and 1 2 3 4 5 6) 54 | 55 | 56 | test: "multiline nested ands can't be flattened" 57 | ------------------------------ 58 | (and 1 59 | (and 2 3)) 60 | ------------------------------ 61 | 62 | 63 | test: "nested ors interspersed with ands can be flattened" 64 | - (or (or 1 2) (and 3 4) (or 5 6)) 65 | - (or 1 2 (and 3 4) 5 6) 66 | 67 | 68 | test: "nested ands interspersed with ors can be flattened" 69 | - (and (and 1 2) (or 3 4) (and 5 6)) 70 | - (and 1 2 (or 3 4) 5 6) 71 | 72 | 73 | test: "using if to convert a boolean expression to a boolean can be removed" 74 | - (if (string? "foo") #true #false) 75 | - (string? "foo") 76 | 77 | 78 | test: "using if to convert a boolean expression to a boolean can't be removed when if is rebound" 79 | ------------------------------ 80 | (define (if a b c) 81 | (displayln "You thought I was an if expression? Fool!")) 82 | (if (string? "foo") #true #false) 83 | ------------------------------ 84 | 85 | 86 | test: "if else false can be refactored to use and" 87 | - (if (+ 4 10) (* 4 9) #false) 88 | - (and (+ 4 10) (* 4 9)) 89 | 90 | 91 | test: "using if to convert a non-boolean expression can be refactored to use and" 92 | - (if 4 #true #false) 93 | - (and 4 #true) 94 | 95 | 96 | test: "if then false else true can be refactored to use not" 97 | - (if 4 #false #true) 98 | - (not 4) 99 | 100 | 101 | test: "when not can be refactored to use unless" 102 | ------------------------------ 103 | (when (not 'foo) 104 | (displayln "not foo")) 105 | ------------------------------ 106 | ------------------------------ 107 | (unless 'foo 108 | (displayln "not foo")) 109 | ------------------------------ 110 | 111 | 112 | test: "refactoring negated when into unless preserves comments" 113 | ------------------------------ 114 | ; comment before 115 | (when 116 | ; strangely positioned comment before 117 | (not 'foo) 118 | ; comment after 119 | (displayln "not foo")) 120 | ------------------------------ 121 | ------------------------------ 122 | ; comment before 123 | ; strangely positioned comment before 124 | (unless 'foo 125 | ; comment after 126 | (displayln "not foo")) 127 | ------------------------------ 128 | 129 | 130 | test: "unless not can be refactored to use when" 131 | ------------------------------ 132 | (unless (not 'foo) 133 | (displayln "foo")) 134 | ------------------------------ 135 | ------------------------------ 136 | (when 'foo 137 | (displayln "foo")) 138 | ------------------------------ 139 | 140 | 141 | test: "refactoring negated unless into when preserves comments" 142 | ------------------------------ 143 | ; comment before 144 | (unless 145 | ; strangely positioned comment before 146 | (not 'foo) 147 | ; comment after 148 | (displayln "foo")) 149 | ------------------------------ 150 | ------------------------------ 151 | ; comment before 152 | ; strangely positioned comment before 153 | (when 'foo 154 | ; comment after 155 | (displayln "foo")) 156 | ------------------------------ 157 | -------------------------------------------------------------------------------- /default-recommendations/boolean-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [boolean-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | rebellion/private/static-name 14 | resyntax/base 15 | resyntax/default-recommendations/private/boolean 16 | resyntax/default-recommendations/private/syntax-lines 17 | resyntax/default-recommendations/private/syntax-tree 18 | syntax/parse) 19 | 20 | 21 | ;@---------------------------------------------------------------------------------------------------- 22 | 23 | 24 | (define-refactoring-rule nested-or-to-flat-or 25 | #:description "Nested `or` expressions can be flattened into a single, equivalent `or` expression." 26 | (~var or-tree (syntax-tree #'or)) 27 | ;; Restricted to single-line expressions for now because the syntax-tree operations don't preserve 28 | ;; any formatting between adjacent leaves. 29 | #:when (oneline-syntax? #'or-tree) 30 | #:when (>= (attribute or-tree.rank) 2) 31 | (or or-tree.leaf ...)) 32 | 33 | 34 | (define-refactoring-rule nested-and-to-flat-and 35 | #:description 36 | "Nested `and` expressions can be flattened into a single, equivalent `and` expression." 37 | (~var and-tree (syntax-tree #'and)) 38 | ;; Restricted to single-line expressions for now because the syntax-tree operations don't preserve 39 | ;; any formatting between adjacent leaves. 40 | #:when (oneline-syntax? #'and-tree) 41 | #:when (>= (attribute and-tree.rank) 2) 42 | (and and-tree.leaf ...)) 43 | 44 | 45 | (define-refactoring-rule if-then-true-else-false-to-condition 46 | #:description "The condition of this `if` expression is already a boolean and can be used directly." 47 | #:literals (if) 48 | (if condition:likely-boolean #true #false) 49 | condition) 50 | 51 | 52 | (define-refactoring-rule if-then-false-else-true-to-not 53 | #:description "This `if` expression can be refactored to an equivalent expression using `not`." 54 | #:literals (if) 55 | (if condition #false #true) 56 | (not condition)) 57 | 58 | 59 | (define-refactoring-rule if-else-false-to-and 60 | #:description "This `if` expression can be refactored to an equivalent expression using `and`." 61 | #:literals (if) 62 | (if condition then #false) 63 | (and condition then)) 64 | 65 | 66 | (define-syntax-class negated-condition 67 | #:attributes (flipped) 68 | #:literals (not) 69 | (pattern (not base-condition:expr) 70 | #:with flipped #`(~replacement base-condition #:original #,this-syntax))) 71 | 72 | 73 | (define-refactoring-rule inverted-when 74 | #:description "This negated `when` expression can be replaced by an `unless` expression." 75 | #:literals (when) 76 | (when-id:when negated:negated-condition body ...) 77 | ((~replacement unless #:original when-id) negated.flipped body ...)) 78 | 79 | 80 | (define-refactoring-rule inverted-unless 81 | #:description "This negated `unless` expression can be replaced by a `when` expression." 82 | #:literals (unless) 83 | (unless-id:unless negated:negated-condition body ...) 84 | ((~replacement when #:original unless-id) negated.flipped body ...)) 85 | 86 | 87 | (define-refactoring-suite boolean-shortcuts 88 | #:rules (if-then-false-else-true-to-not 89 | if-then-true-else-false-to-condition 90 | if-else-false-to-and 91 | inverted-when 92 | inverted-unless 93 | nested-and-to-flat-and 94 | nested-or-to-flat-or)) 95 | -------------------------------------------------------------------------------- /default-recommendations/class-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations class-shortcuts 5 | 6 | 7 | header: 8 | -------------------- 9 | #lang racket/base 10 | (require racket/class) 11 | -------------------- 12 | 13 | 14 | test: "nested send expressions refactorable to flat send+ expression" 15 | -------------------- 16 | (define (f obj x y z) 17 | (send (send (send obj m1 x) m2 y) m3 z)) 18 | -------------------- 19 | -------------------- 20 | (define (f obj x y z) 21 | (send+ obj (m1 x) (m2 y) (m3 z))) 22 | -------------------- 23 | 24 | 25 | test: "two-method nested send expression not refactorable to send+" 26 | -------------------- 27 | (define (f obj x y) 28 | (send (send obj m1 x) m2 y)) 29 | -------------------- 30 | 31 | 32 | test: "instantiate without by-name arguments refactorable to make-object" 33 | -------------------- 34 | (define (f cls x y z) 35 | (instantiate cls (x y z))) 36 | -------------------- 37 | -------------------- 38 | (define (f cls x y z) 39 | (make-object cls x y z)) 40 | -------------------- 41 | 42 | 43 | test: "instantiate without by-position arguments refactorable to new" 44 | -------------------- 45 | (define (f cls x y z) 46 | (instantiate cls () [x x] [y y] [z z])) 47 | -------------------- 48 | -------------------- 49 | (define (f cls x y z) 50 | (new cls [x x] [y y] [z z])) 51 | -------------------- 52 | 53 | 54 | test: "instantiate without any arguments not refactorable" 55 | -------------------- 56 | (define (f cls) 57 | (instantiate cls ())) 58 | -------------------- 59 | -------------------------------------------------------------------------------- /default-recommendations/class-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [class-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require racket/class 13 | resyntax/base 14 | syntax/parse) 15 | 16 | 17 | ;@---------------------------------------------------------------------------------------------------- 18 | 19 | 20 | (define-syntax-class manual-method-chain 21 | #:attributes (initial-object [method 1] [arg 2]) 22 | #:literals (send) 23 | 24 | (pattern (send inner-chain:manual-method-chain last-method:id last-method-arg ...) 25 | #:attr initial-object (attribute inner-chain.initial-object) 26 | #:attr [method 1] (append (attribute inner-chain.method) (list #'last-method)) 27 | #:attr [arg 2] (append (attribute inner-chain.arg) (list (attribute last-method-arg)))) 28 | 29 | (pattern (send (~and initial-object (~not _:manual-method-chain)) 30 | first-method:id 31 | first-method-arg ...) 32 | #:attr [method 1] (list #'first-method) 33 | #:attr [arg 2] (list (attribute first-method-arg)))) 34 | 35 | 36 | (define-refactoring-rule send-chain-to-send+ 37 | #:description 38 | "This method chain made of nested `send` expressions can be written more clearly as a `send+`\ 39 | expression." 40 | chain:manual-method-chain 41 | #:when (>= (length (attribute chain.method)) 3) 42 | (send+ chain.initial-object (chain.method chain.arg ...) ...)) 43 | 44 | 45 | (define-refactoring-rule instantiate-to-make-object 46 | #:description "The `instantiate` form is for mixing positional and by-name constructor arguments.\ 47 | When no by-name arguments are needed, use `make-object` instead." 48 | #:literals (instantiate) 49 | (instantiate cls (by-position-arg ...+)) 50 | (make-object cls by-position-arg ...)) 51 | 52 | 53 | (define-refactoring-rule instantiate-to-new 54 | #:description "The `instantiate` form is for mixing positional and by-name constructor arguments.\ 55 | When no positional arguments are needed, use `new` instead." 56 | #:literals (instantiate) 57 | (instantiate cls () by-name-arg ...+) 58 | (new cls by-name-arg ...)) 59 | 60 | 61 | (define-refactoring-suite class-shortcuts 62 | #:rules (instantiate-to-make-object 63 | instantiate-to-new 64 | send-chain-to-send+)) 65 | -------------------------------------------------------------------------------- /default-recommendations/comparison-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations comparison-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (define x 1) 11 | (define y 2) 12 | ------------------------------ 13 | 14 | 15 | test: "comparison of difference to zero refactorable to direct > comparison" 16 | - (> (- x y) 0) 17 | - (< 0 (- x y)) 18 | - (> x y) 19 | 20 | 21 | test: "comparison of difference to zero refactorable to direct < comparison" 22 | - (< (- x y) 0) 23 | - (> 0 (- x y)) 24 | - (< x y) 25 | 26 | 27 | test: "comparison of difference to zero refactorable to direct >= comparison" 28 | - (<= 0 (- x y)) 29 | - (>= (- x y) 0) 30 | - (>= x y) 31 | 32 | 33 | test: "comparison of difference to zero refactorable to direct <= comparison" 34 | - (>= 0 (- x y)) 35 | - (<= (- x y) 0) 36 | - (<= x y) 37 | 38 | 39 | test: "two double comparisons with same subject refactorable to triple < comparison" 40 | - (and (< x 10) (> x -10)) 41 | - (and (< x 10) (< -10 x)) 42 | - (and (> 10 x) (> x -10)) 43 | - (and (> 10 x) (< -10 x)) 44 | - (and (> x -10) (< x 10)) 45 | - (and (< -10 x) (< x 10)) 46 | - (and (> x -10) (> 10 x)) 47 | - (and (< -10 x) (> 10 x)) 48 | - (< -10 x 10) 49 | 50 | 51 | test: "two double comparisons with same subject refactorable to triple <= comparison" 52 | - (and (<= x 10) (>= x -10)) 53 | - (and (<= x 10) (<= -10 x)) 54 | - (and (>= 10 x) (>= x -10)) 55 | - (and (>= 10 x) (<= -10 x)) 56 | - (and (>= x -10) (<= x 10)) 57 | - (and (<= -10 x) (<= x 10)) 58 | - (and (>= x -10) (>= 10 x)) 59 | - (and (<= -10 x) (>= 10 x)) 60 | - (<= -10 x 10) 61 | 62 | 63 | test: "or-comparisons not refactorable (see https://github.com/jackfirth/resyntax/issues/144)" 64 | - (or (< x 2) (> x 36)) 65 | 66 | 67 | test: "mixed inclusive and exclusive comparisons not refactorable" 68 | - (and (< x 10) (>= x -10)) 69 | -------------------------------------------------------------------------------- /default-recommendations/comparison-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [comparison-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | rebellion/private/static-name 14 | resyntax/base 15 | syntax/parse) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-syntax-class comparison-of-difference-and-zero 22 | #:attributes (direct-comparison) 23 | #:literals (- > < >= <=) 24 | (pattern (> (- x y) 0) #:with direct-comparison #'(> x y)) 25 | (pattern (< (- x y) 0) #:with direct-comparison #'(< x y)) 26 | (pattern (>= (- x y) 0) #:with direct-comparison #'(>= x y)) 27 | (pattern (<= (- x y) 0) #:with direct-comparison #'(<= x y)) 28 | (pattern (> 0 (- x y)) #:with direct-comparison #'(< x y)) 29 | (pattern (< 0 (- x y)) #:with direct-comparison #'(> x y)) 30 | (pattern (>= 0 (- x y)) #:with direct-comparison #'(<= x y)) 31 | (pattern (<= 0 (- x y)) #:with direct-comparison #'(>= x y))) 32 | 33 | 34 | (define-refactoring-rule comparison-of-difference-and-zero-to-direct-comparison 35 | #:description "This comparison can be replaced with a simpler, more direct comparison." 36 | comparison:comparison-of-difference-and-zero 37 | comparison.direct-comparison) 38 | 39 | 40 | (define-syntax-class two-exclusive-comparisons 41 | #:attributes (x lower-bound upper-bound) 42 | #:literals (and > <) 43 | 44 | (pattern (and (< x:id upper-bound:expr) (> x2:id lower-bound:expr)) 45 | #:when (free-identifier=? #'x #'x2)) 46 | 47 | (pattern (and (> x:id lower-bound:expr) (< x2:id upper-bound:expr)) 48 | #:when (free-identifier=? #'x #'x2)) 49 | 50 | (pattern (and (< x:id upper-bound:expr) (< lower-bound:expr x2:id)) 51 | #:when (free-identifier=? #'x #'x2)) 52 | 53 | (pattern (and (< lower-bound:expr x:id) (< x2:id upper-bound:expr)) 54 | #:when (free-identifier=? #'x #'x2)) 55 | 56 | (pattern (and (> upper-bound:expr x:id) (> x2:id lower-bound:expr)) 57 | #:when (free-identifier=? #'x #'x2)) 58 | 59 | (pattern (and (> x:id lower-bound:expr) (> upper-bound:expr x2:id)) 60 | #:when (free-identifier=? #'x #'x2)) 61 | 62 | (pattern (and (> upper-bound:expr x:id) (< lower-bound:expr x2:id)) 63 | #:when (free-identifier=? #'x #'x2)) 64 | 65 | (pattern (and (< lower-bound:expr x:id) (> upper-bound:expr x2:id)) 66 | #:when (free-identifier=? #'x #'x2))) 67 | 68 | 69 | (define-syntax-class two-inclusive-comparisons 70 | #:attributes (x lower-bound upper-bound) 71 | #:literals (and >= <=) 72 | 73 | (pattern (and (<= x:id upper-bound:expr) (>= x2:id lower-bound:expr)) 74 | #:when (free-identifier=? #'x #'x2)) 75 | 76 | (pattern (and (>= x:id lower-bound:expr) (<= x2:id upper-bound:expr)) 77 | #:when (free-identifier=? #'x #'x2)) 78 | 79 | (pattern (and (<= x:id upper-bound:expr) (<= lower-bound:expr x2:id)) 80 | #:when (free-identifier=? #'x #'x2)) 81 | 82 | (pattern (and (<= lower-bound:expr x:id) (<= x2:id upper-bound:expr)) 83 | #:when (free-identifier=? #'x #'x2)) 84 | 85 | (pattern (and (>= upper-bound:expr x:id) (>= x2:id lower-bound:expr)) 86 | #:when (free-identifier=? #'x #'x2)) 87 | 88 | (pattern (and (>= x:id lower-bound:expr) (>= upper-bound:expr x2:id)) 89 | #:when (free-identifier=? #'x #'x2)) 90 | 91 | (pattern (and (>= upper-bound:expr x:id) (<= lower-bound:expr x2:id)) 92 | #:when (free-identifier=? #'x #'x2)) 93 | 94 | (pattern (and (<= lower-bound:expr x:id) (>= upper-bound:expr x2:id)) 95 | #:when (free-identifier=? #'x #'x2))) 96 | 97 | 98 | (define-refactoring-rule two-exclusive-comparisons-to-triple-comparison 99 | #:description 100 | "Comparison functions like `<` accept multiple arguments, so this condition can be simplified." 101 | comparison:two-exclusive-comparisons 102 | (< comparison.lower-bound comparison.x comparison.upper-bound)) 103 | 104 | 105 | (define-refactoring-rule two-inclusive-comparisons-to-triple-comparison 106 | #:description 107 | "Comparison functions like `<=` accept multiple arguments, so this condition can be simplified." 108 | comparison:two-inclusive-comparisons 109 | (<= comparison.lower-bound comparison.x comparison.upper-bound)) 110 | 111 | 112 | (define-refactoring-suite comparison-shortcuts 113 | #:rules (comparison-of-difference-and-zero-to-direct-comparison 114 | two-exclusive-comparisons-to-triple-comparison 115 | two-inclusive-comparisons-to-triple-comparison)) 116 | -------------------------------------------------------------------------------- /default-recommendations/console-io-suggestions-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations console-io-suggestions 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "should suggest 'any linemode with read-line when linemode not specified" 12 | ---------------------------------------- 13 | (define (foo in) 14 | (read-line in)) 15 | ---------------------------------------- 16 | ---------------------------------------- 17 | (define (foo in) 18 | (read-line in 'any)) 19 | ---------------------------------------- 20 | 21 | 22 | test: "should suggest 'any linemode with read-line when linemode and port not specified" 23 | ---------------------------------------- 24 | (define (foo) 25 | (read-line)) 26 | ---------------------------------------- 27 | ---------------------------------------- 28 | (define (foo) 29 | (read-line (current-input-port) 'any)) 30 | ---------------------------------------- 31 | -------------------------------------------------------------------------------- /default-recommendations/console-io-suggestions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [console-io-suggestions refactoring-suite?])) 10 | 11 | 12 | (require racket/file 13 | racket/list 14 | rebellion/private/static-name 15 | resyntax/base 16 | syntax/parse) 17 | 18 | 19 | ;@---------------------------------------------------------------------------------------------------- 20 | 21 | 22 | (define-refactoring-rule read-line-any 23 | #:description 24 | (string-append "Specify a line mode of `'any` with `read-line` to avoid differences between " 25 | "Windows and other platforms.") 26 | #:literals (read-line) 27 | (read-line (~optional port)) 28 | (read-line (~? port (current-input-port)) 'any)) 29 | 30 | 31 | (define-refactoring-suite console-io-suggestions 32 | #:rules (read-line-any)) 33 | -------------------------------------------------------------------------------- /default-recommendations/contract-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations contract-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (require racket/contract/base) 11 | ------------------------------ 12 | 13 | 14 | test: "nested or/c contracts can be flattened" 15 | - (void (or/c 1 2 (or/c 3 4))) 16 | - (void (or/c 1 2 3 4)) 17 | 18 | 19 | test: "flat or/c contracts can't be flattened" 20 | - (or/c 1 2 3) 21 | 22 | 23 | test: "multiple nested or/c contracts can be flattened at once" 24 | - (void (or/c (or/c 1 2) (or/c 3 4) (or/c 5 6))) 25 | - (void (or/c 1 2 3 4 5 6)) 26 | 27 | 28 | test: "deeply nested or/c contracts can be flattened in one pass" 29 | - (void (or/c 1 (or/c 2 (or/c 3 (or/c 4 5 6))))) 30 | - (void (or/c 1 2 3 4 5 6)) 31 | 32 | 33 | test: "multiline nested or/c contracts can't be flattened" 34 | ------------------------------ 35 | (or/c 1 36 | (or/c 2 3)) 37 | ------------------------------ 38 | 39 | 40 | test: "nested and/c contracts can be flattened" 41 | - (void (and/c 1 2 (and/c 3 4))) 42 | - (void (and/c 1 2 3 4)) 43 | 44 | 45 | test: "flat and/c contracts can't be flattened" 46 | - (and/c 1 2 3) 47 | 48 | 49 | test: "multiple nested and/c contracts can be flattened at once" 50 | - (void (and/c (and/c 1 2) (and/c 3 4) (and/c 5 6))) 51 | - (void (and/c 1 2 3 4 5 6)) 52 | 53 | 54 | test: "deeply nested and/c contracts can be flattened in one pass" 55 | - (void (and/c 1 (and/c 2 (and/c 3 (and/c 4 5 6))))) 56 | - (void (and/c 1 2 3 4 5 6)) 57 | 58 | 59 | test: "multiline nested and/c contracts can't be flattened" 60 | ------------------------------ 61 | (and/c 1 62 | (and/c 2 3)) 63 | ------------------------------ 64 | 65 | 66 | test: "nested or/c contracts interspersed with and/c contracts can be flattened" 67 | - (void (or/c (or/c 1 2) (and/c 3 4) (or/c 5 6))) 68 | - (void (or/c 1 2 (and/c 3 4) 5 6)) 69 | 70 | 71 | test: "nested and/c contracts interspersed with or/c contracts can be flattened" 72 | - (void (and/c (and/c 1 2) (or/c 3 4) (and/c 5 6))) 73 | - (void (and/c 1 2 (or/c 3 4) 5 6)) 74 | 75 | 76 | test: "contracts equivalent to path-string? can be refactored to path-string?" 77 | - (void (or/c path? string?)) 78 | - (void (or/c string? path?)) 79 | - (void path-string?) 80 | 81 | 82 | test: "->* contracts using #:rest (listof arg) can be replaced with -> and ellipses" 83 | - (void (->* (string? number?) #:rest (listof symbol?) list?)) 84 | - (void (->* (string? number?) () #:rest (listof symbol?) list?)) 85 | - (void (-> string? number? symbol? ... list?)) 86 | 87 | 88 | test: "infix ->* contracts using #:rest (listof arg) can be replaced with -> and ellipses" 89 | - (void ((string? number?) #:rest (listof symbol?) . ->* . list?)) 90 | - (void (-> string? number? symbol? ... list?)) 91 | 92 | 93 | test: "->* contracts using #:rest and optional arguments not refactorable to -> and ellipses" 94 | - (void (->* () (string?) #:rest (listof symbol?) list?)) 95 | 96 | 97 | test: "provide/contract refactorable to provide with contract-out" 98 | ------------------------------ 99 | (provide/contract [foo integer?]) 100 | (define foo 42) 101 | ------------------------------ 102 | ------------------------------ 103 | (provide (contract-out [foo integer?])) 104 | (define foo 42) 105 | ------------------------------ 106 | 107 | 108 | test: "provide/contract with unprotected submodule refactorable to provide with contract-out" 109 | ------------------------------ 110 | (provide/contract #:unprotected-submodule unsafe [foo integer?]) 111 | (define foo 42) 112 | ------------------------------ 113 | ------------------------------ 114 | (provide (contract-out #:unprotected-submodule unsafe [foo integer?])) 115 | (define foo 42) 116 | ------------------------------ 117 | -------------------------------------------------------------------------------- /default-recommendations/contract-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [contract-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | rebellion/private/static-name 14 | resyntax/base 15 | resyntax/default-recommendations/private/syntax-lines 16 | resyntax/default-recommendations/private/syntax-tree 17 | resyntax/private/syntax-replacement 18 | syntax/parse) 19 | 20 | 21 | ;@---------------------------------------------------------------------------------------------------- 22 | 23 | 24 | (define-refactoring-rule nested-or/c-to-flat-or/c 25 | #:description "Nested `or/c` contracts can be flattened to a single, equivalent `or/c` contract." 26 | (~var or-tree (syntax-tree #'or/c)) 27 | ;; Restricted to single-line expressions for now because the syntax-tree operations don't preserve 28 | ;; any formatting between adjacent leaves. 29 | #:when (oneline-syntax? #'or-tree) 30 | #:when (>= (attribute or-tree.rank) 2) 31 | (or/c or-tree.leaf ...)) 32 | 33 | 34 | (define-refactoring-rule nested-and/c-to-flat-and/c 35 | #:description "Nested `and/c` contracts can be flattened to a single, equivalent `and/c` contract." 36 | (~var and-tree (syntax-tree #'and/c)) 37 | ;; Restricted to single-line expressions for now because the syntax-tree operations don't preserve 38 | ;; any formatting between adjacent leaves. 39 | #:when (oneline-syntax? #'and-tree) 40 | #:when (>= (attribute and-tree.rank) 2) 41 | (and/c and-tree.leaf ...)) 42 | 43 | 44 | (define-refactoring-rule explicit-path-string?-to-path-string? 45 | #:description "This contract is equivalent to the `path-string?` predicate." 46 | #:literals (or/c path? string?) 47 | (~or (or/c path? string?) (or/c string? path?)) 48 | path-string?) 49 | 50 | 51 | (define-refactoring-rule arrow-contract-with-rest-to-arrow-contract-with-ellipses 52 | #:description "This `->*` contract can be rewritten using `->` with ellipses." 53 | #:literals (->* listof) 54 | (->* (arg-contract ...) 55 | (~optional ()) 56 | #:rest (~and rest-list (listof rest-contract)) 57 | result-contract) 58 | (-> arg-contract ... 59 | rest-contract (... ...) 60 | result-contract)) 61 | 62 | 63 | (define-splicing-syntax-class unprotected-submodule-option 64 | (pattern (~optional (~seq #:unprotected-submodule submodule-name)))) 65 | 66 | 67 | (define-refactoring-rule provide/contract-to-contract-out 68 | #:description "The `provide/contract` form is a legacy form made obsolete by `contract-out`." 69 | #:literals (provide/contract) 70 | (provide/contract submod:unprotected-submodule-option item ...) 71 | (provide (contract-out (~@ . submod) item ...))) 72 | 73 | 74 | (define-refactoring-suite contract-shortcuts 75 | #:rules (arrow-contract-with-rest-to-arrow-contract-with-ellipses 76 | explicit-path-string?-to-path-string? 77 | nested-or/c-to-flat-or/c 78 | nested-and/c-to-flat-and/c 79 | provide/contract-to-contract-out)) 80 | -------------------------------------------------------------------------------- /default-recommendations/definition-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [definition-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/list 14 | racket/match 15 | rebellion/private/static-name 16 | resyntax/base 17 | syntax/parse) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define-definition-context-refactoring-rule define-values-values-to-define 24 | #:description "This use of `define-values` is unnecessary." 25 | #:literals (define-values values) 26 | (~seq body-before ... 27 | (~and definition (define-values (id:id ...) (values expr:expr ...))) 28 | body-after ...) 29 | #:with (replacement ...) 30 | #'(~focus-replacement-on (~splicing-replacement ((define id expr) ...) #:original definition)) 31 | (body-before ... replacement ... body-after ...)) 32 | 33 | 34 | (define-definition-context-refactoring-rule inline-unnecessary-define 35 | #:description "This variable is returned immediately and can be inlined." 36 | #:literals (define) 37 | (~seq body-before ... (~and definition (define id1:id expr)) id2:id) 38 | #:when (free-identifier=? #'id1 #'id2) 39 | #:when (match (syntax-property #'id1 'identifier-usages) 40 | [(list _) #true] 41 | [_ #false]) 42 | #:with replacement #'(~replacement expr #:original-splice (definition id2)) 43 | #:with focused (if (empty? (attribute body-before)) 44 | #'replacement 45 | #'(~focus-replacement-on replacement)) 46 | (body-before ... focused)) 47 | 48 | 49 | (define-definition-context-refactoring-rule define-begin-extraction 50 | #:description 51 | "The `begin` in this definition can be extracted into the surrounding definition context." 52 | #:literals (define begin) 53 | (~seq body-before ... 54 | (~and definition (define id:id (begin pre-body ... expr))) 55 | body-after ...) 56 | #:with (replacement ...) 57 | #'(~focus-replacement-on 58 | (~splicing-replacement (pre-body ... (define id expr)) #:original definition)) 59 | (body-before ... replacement ... body-after ...)) 60 | 61 | 62 | (define-definition-context-refactoring-rule define-begin0-extraction 63 | #:description 64 | "The `begin0` in this definition can be extracted into the surrounding definition context." 65 | #:literals (define begin0) 66 | (~seq body-before ... 67 | (~and definition (define id:id (begin0 expr post-body ...))) 68 | body-after ...) 69 | #:with (replacement ...) 70 | #'(~focus-replacement-on 71 | (~splicing-replacement ((define id expr) post-body ...) #:original definition)) 72 | (body-before ... replacement ... body-after ...)) 73 | 74 | 75 | (define-definition-context-refactoring-rule begin0-begin-extraction 76 | #:description 77 | "The `begin` form inside this `begin0` form can be extracted into the surrounding definition\ 78 | context." 79 | #:literals (begin0 begin) 80 | (~seq body-before ... 81 | (~and outer-form (begin0 (begin pre-body ... expr) post-body ...))) 82 | #:with (replacement ...) 83 | #'(~focus-replacement-on 84 | (~splicing-replacement (pre-body ... (begin0 expr post-body ...)) #:original outer-form)) 85 | (body-before ... replacement ...)) 86 | 87 | 88 | (define-definition-context-refactoring-rule inline-unnecessary-begin 89 | #:description "This `begin` form can be flattened into the surrounding definition context." 90 | #:literals (begin) 91 | (~seq body-before ... (~and original (begin inner-body ...)) body-after ...) 92 | 93 | #:with (replacement ...) 94 | (if (and (empty? (attribute body-before)) (empty? (attribute body-after))) 95 | 96 | ; If the begin form being inlined is the *only* form in the surrounding definition context, 97 | ; then it's possible the user has formatted it in such a way that replacing it with multiple 98 | ; forms could require moving those forms onto surrounding lines. In that case, we explicitly 99 | ; don't want to focus the replacement on just the begin forms, because we *should* try to 100 | ; reformat the entire surrounding context. For example, refactoring this code: 101 | ; 102 | ; (map (λ (x) (begin (f x) (g x))) xs) 103 | ; 104 | ; Should produce this code: 105 | ; 106 | ; (map (λ (x) 107 | ; (f x) 108 | ; (g x)) 109 | ; xs) 110 | ; 111 | ; And *not* this code: 112 | ; 113 | ; (map (λ (x) (f x) 114 | ; (g x)) 115 | ; xs) 116 | ; 117 | ; To do that, we have to ensure that the whole lambda form (the entire surrounding definition 118 | ; context) is formatted because we're changing that context from a context with one body form 119 | ; to a context with potentially multiple body forms. 120 | #'(inner-body ...) 121 | 122 | ; In the case that we already know the surrounding context contains other body forms, we know 123 | ; we won't need to reformat the whole context. We focus the replacement on just the inline forms 124 | ; so that we can ignore things like comments surrounding the inlined (begin ...) form. 125 | #'(~focus-replacement-on (~splicing-replacement (inner-body ...) #:original original))) 126 | 127 | (body-before ... replacement ... body-after ...)) 128 | 129 | 130 | (define-refactoring-suite definition-shortcuts 131 | #:rules (begin0-begin-extraction 132 | define-begin-extraction 133 | define-begin0-extraction 134 | define-values-values-to-define 135 | inline-unnecessary-begin 136 | inline-unnecessary-define)) 137 | -------------------------------------------------------------------------------- /default-recommendations/file-io-suggestions-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations file-io-suggestions 5 | 6 | 7 | header: 8 | ---------------------------------------- 9 | #lang racket/base 10 | (require racket/file) 11 | ---------------------------------------- 12 | 13 | 14 | test: "should migrate make-temporary-file with 'directory to make-temporary-directory" 15 | - (void (make-temporary-file #:copy-from 'directory)) 16 | - (void (make-temporary-directory)) 17 | 18 | 19 | test: "should migrate make-temporary-file with template and 'directory to make-temporary-directory" 20 | - (void (make-temporary-file "footmp~a" #:copy-from 'directory)) 21 | - (void (make-temporary-file "footmp~a" 'directory)) 22 | - (void (make-temporary-directory "footmp~a")) 23 | 24 | 25 | test: "should migrate make-temporary-file with base-dir and 'directory to make-temporary-directory" 26 | - (void (make-temporary-file #:base-dir #false #:copy-from 'directory)) 27 | - (void (make-temporary-directory #:base-dir #false)) 28 | 29 | 30 | test: "should not migrate make-temporary-file without 'directory to make-temporary-directory" 31 | - (make-temporary-file #:copy-from #false) 32 | -------------------------------------------------------------------------------- /default-recommendations/file-io-suggestions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [file-io-suggestions refactoring-suite?])) 10 | 11 | 12 | (require racket/file 13 | racket/list 14 | rebellion/private/static-name 15 | resyntax/base 16 | syntax/parse) 17 | 18 | 19 | ;@---------------------------------------------------------------------------------------------------- 20 | 21 | 22 | (define-splicing-syntax-class function-call-argument 23 | #:attributes (keyword expr) 24 | (pattern (~seq expr:expr) #:attr keyword #false) 25 | (pattern (~seq keyword:keyword expr:expr))) 26 | 27 | 28 | (define-splicing-syntax-class function-call-arguments 29 | #:attributes ([positional 1] keyword) 30 | (pattern (~seq arg:function-call-argument ...) 31 | #:cut 32 | #:with (positional ...) 33 | (for/list ([expr (in-list (attribute arg.expr))] 34 | [keyword (in-list (attribute arg.keyword))] 35 | #:unless keyword) 36 | expr) 37 | 38 | #:attr keyword 39 | (for/hasheq ([expr (in-list (attribute arg.expr))] 40 | [keyword (in-list (attribute arg.keyword))] 41 | #:when keyword) 42 | (values (syntax-e keyword) expr)))) 43 | 44 | 45 | (define-refactoring-rule make-temporary-directory-migration 46 | #:description "Use `make-temporary-directory` to make directories instead of `make-temporary-file`." 47 | #:literals (make-temporary-file) 48 | #:datum-literals (quote directory) 49 | 50 | (make-temporary-file args:function-call-arguments) 51 | #:with 'directory 52 | (or (and (>= (length (attribute args.positional)) 2) 53 | (second (attribute args.positional))) 54 | (hash-ref (attribute args.keyword) '#:copy-from #false)) 55 | #:cut 56 | #:attr template-arg 57 | (and (not (empty? (attribute args.positional))) 58 | (first (attribute args.positional))) 59 | #:attr base-dir-arg 60 | (or (and (>= (length (attribute args.positional)) 3) 61 | (third (attribute args.positional))) 62 | (hash-ref (attribute args.keyword) '#:base-dir #false)) 63 | 64 | (make-temporary-directory (~? template-arg) (~? (~@ #:base-dir base-dir-arg)))) 65 | 66 | 67 | (define-refactoring-suite file-io-suggestions 68 | #:rules (make-temporary-directory-migration)) 69 | -------------------------------------------------------------------------------- /default-recommendations/formatting-preservation-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations default-recommendations 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "refactoring an expression doesn't affect formatting of unrefactored code" 12 | ---------------------------------------- 13 | ( displayln "foo" ) 14 | (or 1 (or 2 3)) 15 | ( displayln "bar" ) 16 | ---------------------------------------- 17 | ---------------------------------------- 18 | ( displayln "foo" ) 19 | (or 1 2 3) 20 | ( displayln "bar" ) 21 | ---------------------------------------- 22 | 23 | 24 | test: "define-let-to-double-define doesn't reformat the entire definition context" 25 | ---------------------------------------- 26 | (define (f) 27 | ( displayln "foo" ) 28 | (define y (let ([x 1]) (* x 2))) 29 | ( displayln "bar" )) 30 | ---------------------------------------- 31 | ---------------------------------------- 32 | (define (f) 33 | ( displayln "foo" ) 34 | (define x 1) 35 | (define y (* x 2)) 36 | ( displayln "bar" )) 37 | ---------------------------------------- 38 | 39 | 40 | test: "let-to-define doesn't reformat the entire definition context" 41 | ---------------------------------------- 42 | (define (f) 43 | ( displayln "foo" ) 44 | (let ([x 1]) 45 | (* x 2))) 46 | ---------------------------------------- 47 | ---------------------------------------- 48 | (define (f) 49 | ( displayln "foo" ) 50 | (define x 1) 51 | (* x 2)) 52 | ---------------------------------------- 53 | 54 | 55 | test: "cond-let-to-cond-define doesn't reformat the entire cond expression" 56 | ---------------------------------------- 57 | (define (f c1 c2) 58 | (cond 59 | [c1 ( displayln "foo" )] 60 | [c2 61 | ( displayln "bar" ) 62 | (let ([x 1]) 63 | (* x 2))] 64 | [else ( displayln "else" )])) 65 | ---------------------------------------- 66 | ---------------------------------------- 67 | (define (f c1 c2) 68 | (cond 69 | [c1 ( displayln "foo" )] 70 | [c2 71 | ( displayln "bar" ) 72 | (define x 1) 73 | (* x 2)] 74 | [else ( displayln "else" )])) 75 | ---------------------------------------- 76 | -------------------------------------------------------------------------------- /default-recommendations/function-definition-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [function-definition-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | guard 14 | racket/list 15 | resyntax/base 16 | resyntax/default-recommendations/private/lambda-by-any-name 17 | resyntax/default-recommendations/private/syntax-lines 18 | syntax/parse) 19 | 20 | 21 | ;@---------------------------------------------------------------------------------------------------- 22 | 23 | 24 | (define/guard (free-identifiers=? ids other-ids) 25 | (define id-list (syntax->list ids)) 26 | (define other-id-list (syntax->list other-ids)) 27 | (guard (equal? (length id-list) (length other-id-list)) #:else #false) 28 | (for/and ([id (in-list id-list)] [other-id (in-list other-id-list)]) 29 | (free-identifier=? id other-id))) 30 | 31 | 32 | (define-syntax-class lambda-header 33 | (pattern _:id) 34 | (pattern (formal ...)) 35 | (pattern (formal ... . rest-arg:id))) 36 | 37 | 38 | (define-syntax-class possibly-nested-lambdas 39 | #:attributes ([argument-lists 1] [body 1]) 40 | 41 | (pattern (_:lambda-by-any-name first-argument-list:lambda-header nested:possibly-nested-lambdas) 42 | #:with (argument-lists ...) (cons #'first-argument-list (attribute nested.argument-lists)) 43 | #:with (body ...) #'(nested.body ...)) 44 | 45 | (pattern 46 | (_:lambda-by-any-name 47 | first-argument-list:lambda-header 48 | (~and initial-body (~not _:possibly-nested-lambdas)) 49 | remaining-body ...) 50 | #:with (argument-lists ...) #'(first-argument-list) 51 | #:with (body ...) #'(initial-body remaining-body ...))) 52 | 53 | 54 | (define (zero-argument-formals? formals) 55 | (syntax-parse formals 56 | [() #true] 57 | [_ #false])) 58 | 59 | 60 | (define/guard (build-function-header original-header formal-lists) 61 | (guard-match (cons first-formals remaining-formals) formal-lists #:else 62 | original-header) 63 | (guard (or (identifier? original-header) (not (zero-argument-formals? first-formals))) #:else 64 | original-header) 65 | (with-syntax ([formals first-formals]) 66 | (build-function-header #`(#,original-header . formals) remaining-formals))) 67 | 68 | 69 | (define/guard (build-function-body original-header formal-lists innermost-body-forms) 70 | (guard-match (cons first-formals remaining-formals) formal-lists #:else 71 | innermost-body-forms) 72 | (guard (or (identifier? original-header) (not (zero-argument-formals? first-formals))) #:else 73 | (build-lambda-expressions formal-lists innermost-body-forms)) 74 | (with-syntax ([formals first-formals]) 75 | (build-function-body #`(#,original-header . formals) remaining-formals innermost-body-forms))) 76 | 77 | 78 | (define/guard (build-lambda-expressions formal-lists innermost-body-forms) 79 | (guard-match (cons first-formals remaining-formals) formal-lists #:else 80 | innermost-body-forms) 81 | (list #`(λ #,first-formals #,@(build-lambda-expressions remaining-formals innermost-body-forms)))) 82 | 83 | 84 | (define-refactoring-rule define-lambda-to-define 85 | #:description "The `define` form supports a shorthand for defining functions." 86 | #:literals (define) 87 | (define header lambda-form:possibly-nested-lambdas) 88 | #:when (not (syntax-property this-syntax 'class-body)) 89 | #:do [(define multiline-lambda-header-count 90 | (count multiline-syntax? (attribute lambda-form.argument-lists)))] 91 | #:when (< multiline-lambda-header-count 2) 92 | #:when (oneline-syntax? #'header) 93 | #:when (or (identifier? #'header) (zero? multiline-lambda-header-count)) 94 | #:when (or (identifier? #'header) 95 | (not (zero-argument-formals? (first (attribute lambda-form.argument-lists))))) 96 | #:with new-header (build-function-header #'header (attribute lambda-form.argument-lists)) 97 | #:with (new-body ...) 98 | (build-function-body #'header (attribute lambda-form.argument-lists) (attribute lambda-form.body)) 99 | (define new-header new-body ...)) 100 | 101 | 102 | (define-refactoring-rule define-case-lambda-to-define 103 | #:description "This use of `case-lambda` is equivalent to using `define` with optional arguments." 104 | #:literals (define case-lambda) 105 | 106 | (define id:id 107 | (case-lambda 108 | [(case1-arg:id ...) (usage:id usage1:id ... default:expr)] 109 | [(case2-arg:id ... bonus-arg:id) body ...])) 110 | 111 | #:when (oneline-syntax? #'default) 112 | #:when (free-identifier=? #'id #'usage) 113 | 114 | #:when (and (equal? (length (attribute case1-arg)) 115 | (length (attribute case2-arg))) 116 | (equal? (length (attribute case1-arg)) 117 | (length (attribute usage1)))) 118 | 119 | #:when (for/and ([case1-arg-id (in-list (attribute case1-arg))] 120 | [case2-arg-id (in-list (attribute case2-arg))] 121 | [usage1-id (in-list (attribute usage1))]) 122 | (and (equal? (syntax-e case1-arg-id) (syntax-e case2-arg-id)) 123 | (equal? (syntax-e case1-arg-id) (syntax-e usage1-id)))) 124 | 125 | (define (id case2-arg ... [bonus-arg default]) 126 | body ...)) 127 | 128 | 129 | (define-refactoring-suite function-definition-shortcuts 130 | #:rules (define-lambda-to-define 131 | define-case-lambda-to-define)) 132 | -------------------------------------------------------------------------------- /default-recommendations/function-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations function-shortcuts 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "apply with cons can be flattened" 12 | - (apply + 0 (cons 1 '(2 3))) 13 | - (apply + 0 1 '(2 3)) 14 | 15 | 16 | test: "apply with recursive cons can be flattened" 17 | - (apply + 0 (cons 1 (cons 2 '(3 4)))) 18 | - (apply + 0 1 2 '(3 4)) 19 | 20 | 21 | test: "apply with list* can be flattened" 22 | - (apply + 0 (list* 1 2 '(3 4))) 23 | - (apply + 0 1 2 '(3 4)) 24 | 25 | 26 | test: "apply with recursive list* can be flattened" 27 | - (apply + 0 (list* 1 2 (list* 3 4 '(5 6)))) 28 | - (apply + 0 1 2 3 4 '(5 6)) 29 | 30 | 31 | test: "apply with quasiquoted list can be flattened" 32 | - (apply + 0 `(1 2 ,@'(3 4))) 33 | - (apply + 0 1 2 '(3 4)) 34 | 35 | 36 | test: "single-case case-lambda refactorable to regular lambda" 37 | - (case-lambda [(x y z) (+ x y z)]) 38 | - (λ (x y z) (+ x y z)) 39 | -------------------------------------------------------------------------------- /default-recommendations/function-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [function-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | rebellion/private/static-name 14 | resyntax/base 15 | resyntax/default-recommendations/private/literal-constant 16 | resyntax/private/syntax-replacement 17 | syntax/parse) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define-syntax-class unquoted 24 | #:attributes (expr) 25 | #:literals (unquote) 26 | (pattern expr:literal-constant) 27 | (pattern (unquote expr:expr))) 28 | 29 | 30 | (define-syntax-class trailing-list-argument 31 | #:attributes ([lifted 1] trailing) 32 | #:literals (cons list* quasiquote unquote-splicing) 33 | 34 | (pattern (cons arg rest:trailing-list-argument) 35 | #:cut 36 | #:with (lifted ...) #'(arg rest.lifted ...) 37 | #:with trailing #'rest.trailing) 38 | 39 | (pattern (cons arg trailing:expr) 40 | #:cut 41 | #:with (lifted ...) #'(arg)) 42 | 43 | (pattern (list* arg ... rest:trailing-list-argument) 44 | #:cut 45 | #:with (lifted ...) #'(arg ... rest.lifted ...) 46 | #:with trailing #'rest.trailing) 47 | 48 | (pattern (list* arg ... rest:expr) 49 | #:cut 50 | #:with (lifted ...) #'(arg ...) 51 | #:with trailing #'rest) 52 | 53 | (pattern (quasiquote (arg:unquoted ... (unquote-splicing rest))) 54 | #:cut 55 | #:with (lifted ...) #'(arg.expr ...) 56 | #:with trailing #'rest)) 57 | 58 | 59 | (define-refactoring-rule apply-flattening 60 | #:description 61 | "The `apply` function accepts single arguments in addition to a trailing list argument." 62 | #:literals (apply) 63 | ((~and id apply) function:expr arg ... trailing-arg:trailing-list-argument) 64 | (id function arg ... trailing-arg.lifted ... trailing-arg.trailing)) 65 | 66 | 67 | (define-refactoring-rule case-lambda-with-single-case-to-lambda 68 | #:description "This `case-lambda` form only has one case. Use a regular lambda instead." 69 | #:literals (case-lambda) 70 | (case-lambda [args body ...]) 71 | (λ args body ...)) 72 | 73 | 74 | (define-refactoring-suite function-shortcuts 75 | #:rules (apply-flattening 76 | case-lambda-with-single-case-to-lambda)) 77 | -------------------------------------------------------------------------------- /default-recommendations/gap-preservation-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations/gap-preservation gap-preservation-rules 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "comments preserved in splice when form inserted at front" 12 | ----------------------------------- 13 | (define (code insert-foo-first a b) 14 | (insert-foo-first a 15 | ; comment 16 | b)) 17 | ----------------------------------- 18 | ----------------------------------- 19 | (define (code insert-foo-first a b) 20 | ("foo" a 21 | ; comment 22 | b)) 23 | ----------------------------------- 24 | 25 | 26 | test: "later comments preserved in splice when form inserted after first" 27 | ----------------------------------- 28 | (define (code insert-foo-second a b c) 29 | (insert-foo-second a 30 | b 31 | ; preserved comment 32 | c)) 33 | ----------------------------------- 34 | ----------------------------------- 35 | (define (code insert-foo-second a b c) 36 | (a "foo" 37 | b 38 | ; preserved comment 39 | c)) 40 | ----------------------------------- 41 | 42 | 43 | test: "not refactorable when comment dropped due to inserted form" 44 | ----------------------------------- 45 | (define (code insert-foo-second a b c) 46 | (insert-foo-second a 47 | ; dropped comment 48 | b 49 | c)) 50 | ----------------------------------- 51 | 52 | 53 | test: "comments preserved in splice when form inserted at end" 54 | ----------------------------------- 55 | (define (code insert-foo-last a b c) 56 | (insert-foo-last a 57 | b 58 | ; comment 59 | c)) 60 | ----------------------------------- 61 | ----------------------------------- 62 | (define (code insert-foo-last a b c) 63 | (a b 64 | ; comment 65 | c 66 | "foo")) 67 | ----------------------------------- 68 | 69 | 70 | test: "comments preserved in splice when first form replaced" 71 | ----------------------------------- 72 | (define (code replace-first-with-foo a b c) 73 | (replace-first-with-foo a 74 | ; comment after 75 | b 76 | c)) 77 | ----------------------------------- 78 | ----------------------------------- 79 | (define (code replace-first-with-foo a b c) 80 | ; comment after 81 | ("foo" b c)) 82 | ----------------------------------- 83 | 84 | 85 | test: "comments preserved in splice when second form replaced" 86 | ----------------------------------- 87 | (define (code replace-second-with-foo a b c) 88 | (replace-second-with-foo a 89 | ; comment before 90 | b 91 | ; comment after 92 | c)) 93 | ----------------------------------- 94 | ----------------------------------- 95 | (define (code replace-second-with-foo a b c) 96 | ; comment before 97 | (a "foo" 98 | ; comment after 99 | c)) 100 | ----------------------------------- 101 | 102 | 103 | test: "comments preserved in splice when last form replaced" 104 | ----------------------------------- 105 | (define (code replace-last-with-foo a b c) 106 | (replace-last-with-foo a 107 | b 108 | ; comment before 109 | c)) 110 | ----------------------------------- 111 | ----------------------------------- 112 | (define (code replace-last-with-foo a b c) 113 | (a b 114 | ; comment before 115 | "foo")) 116 | ----------------------------------- 117 | 118 | 119 | test: "comments preserved in splice when first and last forms replaced" 120 | ----------------------------------- 121 | (define (code replace-first-and-last-with-foo a b c) 122 | (replace-first-and-last-with-foo a 123 | ; comment after 124 | b 125 | ; comment before 126 | c)) 127 | ----------------------------------- 128 | ----------------------------------- 129 | (define (code replace-first-and-last-with-foo a b c) 130 | ; comment after 131 | ("foo" b 132 | ; comment before 133 | "foo")) 134 | ----------------------------------- 135 | -------------------------------------------------------------------------------- /default-recommendations/gap-preservation.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | ;; These aren't real refactoring rules. They're only used for testing Resyntax. Specifically, they're 5 | ;; used to test that Resyntax properly preserves comments in between sequences of forms that are left 6 | ;; unchanged by a refactoring rule, even when forms before and after that sequence are changed. See 7 | ;; the accompanying tests in gap-preservation-test.rkt for examples. 8 | 9 | 10 | (require racket/contract/base) 11 | 12 | 13 | (provide 14 | (contract-out 15 | [gap-preservation-rules refactoring-suite?])) 16 | 17 | 18 | (require rebellion/private/static-name 19 | resyntax/base 20 | resyntax/private/syntax-neighbors) 21 | 22 | 23 | ;@---------------------------------------------------------------------------------------------------- 24 | 25 | 26 | (define-refactoring-rule suggest-inserting-foo-first 27 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 28 | #:datum-literals (insert-foo-first) 29 | (insert-foo-first a ...) 30 | ("foo" a ...)) 31 | 32 | 33 | (define-refactoring-rule suggest-inserting-foo-second 34 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 35 | #:datum-literals (insert-foo-second) 36 | (insert-foo-second a0 a ...) 37 | (a0 "foo" a ...)) 38 | 39 | 40 | (define-refactoring-rule suggest-inserting-foo-last 41 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 42 | #:datum-literals (insert-foo-last) 43 | (insert-foo-last a ...) 44 | (a ... "foo")) 45 | 46 | 47 | (define-refactoring-rule suggest-inserting-foo-first-and-last 48 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 49 | #:datum-literals (insert-foo-first-and-last) 50 | (insert-foo-first-and-last a ...) 51 | ("foo" a ... "foo")) 52 | 53 | 54 | (define-refactoring-rule suggest-replacing-first-with-foo 55 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 56 | #:datum-literals (replace-first-with-foo) 57 | (replace-first-with-foo old a ...) 58 | ((~replacement "foo" #:original old) a ...)) 59 | 60 | 61 | (define-refactoring-rule suggest-replacing-second-with-foo 62 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 63 | #:datum-literals (replace-second-with-foo) 64 | (replace-second-with-foo a0 old a ...) 65 | (a0 (~replacement "foo" #:original old) a ...)) 66 | 67 | 68 | (define-refactoring-rule suggest-replacing-last-with-foo 69 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 70 | #:datum-literals (replace-last-with-foo) 71 | (replace-last-with-foo a ... old) 72 | (a ... (~replacement "foo" #:original old))) 73 | 74 | 75 | (define-refactoring-rule suggest-replacing-first-and-last-with-foo 76 | #:description "This refactoring rule is for testing Resyntax, ignore its suggestions." 77 | #:datum-literals (replace-first-and-last-with-foo) 78 | (replace-first-and-last-with-foo old1 a ... old2) 79 | ((~replacement "foo" #:original old1) a ... (~replacement "foo" #:original old2))) 80 | 81 | 82 | (define-refactoring-suite gap-preservation-rules 83 | #:rules (suggest-inserting-foo-first 84 | suggest-inserting-foo-second 85 | suggest-inserting-foo-last 86 | suggest-inserting-foo-first-and-last 87 | suggest-replacing-first-with-foo 88 | suggest-replacing-second-with-foo 89 | suggest-replacing-last-with-foo 90 | suggest-replacing-first-and-last-with-foo)) 91 | -------------------------------------------------------------------------------- /default-recommendations/hash-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations hash-shortcuts 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "hash-ref with constant lambda can be simplified to hash-ref without lambda" 12 | ------------------------------ 13 | (define h (make-hash)) 14 | (define k 'a) 15 | (hash-ref h k (λ () 42)) 16 | ------------------------------ 17 | ------------------------------ 18 | (define h (make-hash)) 19 | (define k 'a) 20 | (hash-ref h k 42) 21 | ------------------------------ 22 | 23 | 24 | test: "hash-ref with non-constant lambda cannot be simplified to hash-ref without lambda" 25 | ------------------------------ 26 | (define h (make-hash)) 27 | (define k 'a) 28 | (define (f x) 29 | x) 30 | (hash-ref h k (λ () (f 42))) 31 | ------------------------------ 32 | 33 | 34 | test: "hash-ref! with constant lambda can be simplified to hash-ref! without lambda" 35 | ------------------------------ 36 | (define h (make-hash)) 37 | (define k 'a) 38 | (hash-ref! h k (λ () 42)) 39 | ------------------------------ 40 | ------------------------------ 41 | (define h (make-hash)) 42 | (define k 'a) 43 | (hash-ref! h k 42) 44 | ------------------------------ 45 | 46 | 47 | test: "hash-ref! with non-constant lambda cannot be simplified to hash-ref! without lambda" 48 | ------------------------------ 49 | (define h (make-hash)) 50 | (define k 'a) 51 | (define (f x) 52 | x) 53 | (hash-ref! h k (λ () (f 42))) 54 | ------------------------------ 55 | 56 | 57 | test: "hash-ref with hash-set! can be simplified to hash-ref!" 58 | ------------------------------ 59 | (define h (make-hash)) 60 | (define k 'a) 61 | (hash-ref h k (λ () 62 | (define v (+ 1 2 3)) 63 | (hash-set! h k v) 64 | v)) 65 | ------------------------------ 66 | ------------------------------ 67 | (define h (make-hash)) 68 | (define k 'a) 69 | (or (hash-ref h k #false) 70 | (let ([v (+ 1 2 3)]) 71 | (hash-set! h k v) 72 | v)) 73 | ------------------------------ 74 | ------------------------------ 75 | (define h (make-hash)) 76 | (define k 'a) 77 | (hash-ref! h k (λ () (+ 1 2 3))) 78 | ------------------------------ 79 | 80 | 81 | test: "hash-ref with hash-set! and literal keys can be simplified to hash-ref!" 82 | ------------------------------ 83 | (define h (make-hash)) 84 | (hash-ref h 'a (λ () 85 | (define v (+ 1 2 3)) 86 | (hash-set! h 'a v) 87 | v)) 88 | ------------------------------ 89 | ------------------------------ 90 | (define h (make-hash)) 91 | (or (hash-ref h 'a #false) 92 | (let ([v (+ 1 2 3)]) 93 | (hash-set! h 'a v) 94 | v)) 95 | ------------------------------ 96 | ------------------------------ 97 | (define h (make-hash)) 98 | (hash-ref! h 'a (λ () (+ 1 2 3))) 99 | ------------------------------ 100 | 101 | 102 | test: "hash-ref with hash-set! lambda with constant can be simplified to hash-ref!" 103 | ------------------------------ 104 | (define h (make-hash)) 105 | (define k 'a) 106 | (hash-ref h k (λ () 107 | (hash-set! h k 0) 108 | 0)) 109 | ------------------------------ 110 | ------------------------------ 111 | (define h (make-hash)) 112 | (define k 'a) 113 | (hash-ref h k (λ () 114 | (define v 0) 115 | (hash-set! h k v) 116 | v)) 117 | ------------------------------ 118 | ------------------------------ 119 | (define h (make-hash)) 120 | (define k 'a) 121 | (hash-ref! h k 0) 122 | ------------------------------ 123 | 124 | 125 | test: "hash-ref with hash-set! lambda with thunk can be simplified to hash-ref!" 126 | ------------------------------ 127 | (define h (make-hash)) 128 | (define k 'a) 129 | (hash-ref h k (λ () 130 | (define v (make-hash)) 131 | (hash-set! h k v) 132 | v)) 133 | ------------------------------ 134 | ------------------------------ 135 | (define h (make-hash)) 136 | (define k 'a) 137 | (hash-ref! h k make-hash) 138 | ------------------------------ 139 | 140 | 141 | test: "hash-set! with hash-ref can be simplified to hash-update!" 142 | ------------------------------ 143 | (define h (make-hash)) 144 | (define k 'a) 145 | (hash-set! h k (+ 5 (hash-ref h k 0))) 146 | ------------------------------ 147 | ------------------------------ 148 | (define h (make-hash)) 149 | (define k 'a) 150 | (hash-update! h k (λ (v) (+ 5 v)) 0) 151 | ------------------------------ 152 | 153 | 154 | test: "hash-set! with hash-ref and literal keys can be simplified to hash-update!" 155 | ------------------------------ 156 | (define h (make-hash)) 157 | (hash-set! h 'a (+ 5 (hash-ref h 'a 0))) 158 | ------------------------------ 159 | ------------------------------ 160 | (define h (make-hash)) 161 | (hash-update! h 'a (λ (v) (+ 5 v)) 0) 162 | ------------------------------ 163 | 164 | 165 | test: "hash-set! with hash-ref can be simplified to hash-update! without lambda" 166 | ------------------------------ 167 | (define h (make-hash)) 168 | (define k 'a) 169 | (hash-set! h k (add1 (hash-ref h k 0))) 170 | ------------------------------ 171 | ------------------------------ 172 | (define h (make-hash)) 173 | (define k 'a) 174 | (hash-update! h k add1 0) 175 | ------------------------------ 176 | 177 | 178 | test: "hash-set! with hash-ref cannot be simplified when v would shadow" 179 | ------------------------------ 180 | (define h (make-hash)) 181 | (define k 'a) 182 | (define v 5) 183 | (hash-set! h k (+ v (hash-ref h k 0))) 184 | ------------------------------ 185 | 186 | 187 | test: "hash-map with key-returning lamda can be refactored to hash-keys" 188 | ------------------------------ 189 | (define h (make-hash)) 190 | (hash-map h (λ (k v) k)) 191 | ------------------------------ 192 | ------------------------------ 193 | (define h (make-hash)) 194 | (hash-keys h) 195 | ------------------------------ 196 | 197 | 198 | test: "hash-map with value-returning lamda can be refactored to hash-values" 199 | ------------------------------ 200 | (define h (make-hash)) 201 | (hash-map h (λ (k v) v)) 202 | ------------------------------ 203 | ------------------------------ 204 | (define h (make-hash)) 205 | (hash-values h) 206 | ------------------------------ 207 | -------------------------------------------------------------------------------- /default-recommendations/hash-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [hash-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/list 14 | racket/set 15 | rebellion/private/static-name 16 | resyntax/base 17 | resyntax/default-recommendations/private/lambda-by-any-name 18 | resyntax/default-recommendations/private/literal-constant 19 | resyntax/default-recommendations/private/pure-expression 20 | resyntax/default-recommendations/private/syntax-equivalence 21 | resyntax/default-recommendations/private/syntax-identifier-sets 22 | resyntax/private/syntax-neighbors 23 | syntax/parse) 24 | 25 | 26 | ;@---------------------------------------------------------------------------------------------------- 27 | 28 | 29 | (define-refactoring-rule hash-ref-with-constant-lambda-to-hash-ref-without-lambda 30 | #:description "The lambda can be removed from the failure result in this `hash-ref` expression." 31 | #:literals (hash-ref) 32 | ((~and ref hash-ref) h:expr k:expr (~and lambda-expr (_:lambda-by-any-name () v:literal-constant))) 33 | (ref h k (~replacement v #:original lambda-expr))) 34 | 35 | 36 | (define-refactoring-rule hash-ref!-with-constant-lambda-to-hash-ref!-without-lambda 37 | #:description "The lambda can be removed from the failure result in this `hash-ref!` expression." 38 | #:literals (hash-ref!) 39 | ((~and ref hash-ref!) h:expr k:expr 40 | (~and lambda-expr (_:lambda-by-any-name () v:literal-constant))) 41 | (ref h k (~replacement v #:original lambda-expr))) 42 | 43 | 44 | (define-syntax-class value-initializer 45 | #:attributes (failure-result-form) 46 | (pattern failure-result-form:literal-constant) 47 | (pattern (failure-result-form:id)) 48 | (pattern expr:expr #:with failure-result-form #'(λ () expr))) 49 | 50 | 51 | (define-refactoring-rule hash-ref-set!-to-hash-ref! 52 | #:description "This expression can be replaced with a simpler, equivalent `hash-ref!` expression." 53 | #:literals (hash-ref hash-set! define) 54 | (hash-ref 55 | h1:id 56 | k1:pure-expression 57 | (_:lambda-by-any-name 58 | () 59 | (define v1:id initializer:value-initializer) 60 | (hash-set! h2:id k2:pure-expression v2:id) 61 | v3:id)) 62 | #:when (free-identifier=? #'h1 #'h2) 63 | #:when (syntax-free-identifier=? #'k1 #'k2) 64 | #:when (free-identifier=? #'v1 #'v2) 65 | #:when (free-identifier=? #'v1 #'v3) 66 | (hash-ref! h1 k1 initializer.failure-result-form)) 67 | 68 | 69 | (define-refactoring-rule hash-ref-set!-with-constant-to-hash-ref! 70 | #:description "This expression can be replaced with a simpler, equivalent `hash-ref!` expression." 71 | #:literals (hash-ref hash-set! define) 72 | (hash-ref 73 | h1:id 74 | k1:pure-expression 75 | (_:lambda-by-any-name 76 | () 77 | (hash-set! h2:id k2:pure-expression v1:literal-constant) 78 | v2:literal-constant)) 79 | #:when (free-identifier=? #'h1 #'h2) 80 | #:when (syntax-free-identifier=? #'k1 #'k2) 81 | #:when (equal? (attribute v1.value) (attribute v2.value)) 82 | (hash-ref! h1 k1 v1)) 83 | 84 | 85 | (define-refactoring-rule or-hash-ref-set!-to-hash-ref! 86 | #:description "This expression can be replaced with a simpler, equivalent `hash-ref!` expression." 87 | #:literals (or hash-ref hash-set! let) 88 | (or (hash-ref h1:id k1:pure-expression #false) 89 | (let ([v1:id initializer:value-initializer]) 90 | (hash-set! h2:id k2:pure-expression v2:id) 91 | v3:id)) 92 | #:when (free-identifier=? #'h1 #'h2) 93 | #:when (syntax-free-identifier=? #'k1 #'k2) 94 | #:when (free-identifier=? #'v1 #'v2) 95 | #:when (free-identifier=? #'v1 #'v3) 96 | (hash-ref! h1 k1 initializer.failure-result-form)) 97 | 98 | 99 | (define-refactoring-rule hash-set!-ref-to-hash-update! 100 | #:description 101 | "This expression can be replaced with a simpler, equivalent `hash-update!` expression." 102 | #:literals (hash-ref hash-set!) 103 | (hash-set! h1:id k1:pure-expression 104 | (f:id arg-before:expr ... 105 | (hash-ref h2:id k2:pure-expression (~optional failure-result)) 106 | arg-after:expr ...)) 107 | #:when (free-identifier=? #'h1 #'h2) 108 | #:when (syntax-free-identifier=? #'k1 #'k2) 109 | #:when (for/and ([id (in-syntax-identifiers #'(f arg-before ... arg-after ...))]) 110 | (not (equal? (syntax-e id) 'v))) 111 | #:with updater 112 | (if (and (empty? (attribute arg-before)) (empty? (attribute arg-after))) 113 | #'f 114 | #'(λ (v) (f arg-before ... v arg-after ...))) 115 | (hash-update! h1 k1 updater (~? failure-result))) 116 | 117 | 118 | (define-refactoring-rule hash-map-to-hash-keys 119 | #:description "This `hash-map` expression is equivalent to the `hash-keys` function." 120 | #:literals (hash-map) 121 | (hash-map h (_:lambda-by-any-name (k1:id v) k2:id)) 122 | #:when (free-identifier=? #'k1 #'k2) 123 | (hash-keys h)) 124 | 125 | 126 | (define-refactoring-rule hash-map-to-hash-values 127 | #:description "This `hash-map` expression is equivalent to the `hash-values` function." 128 | #:literals (hash-map) 129 | (hash-map h (_:lambda-by-any-name (k v1:id) v2:id)) 130 | #:when (free-identifier=? #'v1 #'v2) 131 | (hash-values h)) 132 | 133 | 134 | (define-refactoring-suite hash-shortcuts 135 | #:rules (hash-map-to-hash-keys 136 | hash-map-to-hash-values 137 | hash-ref-set!-to-hash-ref! 138 | hash-ref-set!-with-constant-to-hash-ref! 139 | hash-ref-with-constant-lambda-to-hash-ref-without-lambda 140 | hash-ref!-with-constant-lambda-to-hash-ref!-without-lambda 141 | hash-set!-ref-to-hash-update! 142 | or-hash-ref-set!-to-hash-ref!)) 143 | -------------------------------------------------------------------------------- /default-recommendations/legacy-contract-migrations-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations legacy-contract-migrations 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (require racket/contract/base) 11 | ------------------------------ 12 | 13 | 14 | test: "predicate/c in expression position refactorable to ->" 15 | - (void predicate/c) 16 | - (void (-> any/c boolean?)) 17 | 18 | 19 | test: "predicate/c in contract-out refactorable to ->" 20 | ------------------------------ 21 | (provide (contract-out [foo? predicate/c])) 22 | (define (foo? _) 23 | #true) 24 | ------------------------------ 25 | ------------------------------ 26 | (provide (contract-out [foo? (-> any/c boolean?)])) 27 | (define (foo? _) 28 | #true) 29 | ------------------------------ 30 | 31 | 32 | test: "predicate/c in define/contract refactorable to ->" 33 | ------------------------------ 34 | (require racket/contract/region) 35 | (define/contract (foo? _) 36 | predicate/c 37 | #true) 38 | ------------------------------ 39 | ------------------------------ 40 | (require racket/contract/region) 41 | (define/contract (foo? _) 42 | (-> any/c boolean?) 43 | #true) 44 | ------------------------------ 45 | -------------------------------------------------------------------------------- /default-recommendations/legacy-contract-migrations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [legacy-contract-migrations refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/syntax 14 | rebellion/private/static-name 15 | resyntax/base) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-refactoring-rule false/c-migration 22 | #:description "`false/c` is an alias for `#f` that exists for backwards compatibility." 23 | #:literals (false/c) 24 | false/c 25 | #false) 26 | 27 | 28 | (define-refactoring-rule symbols-migration 29 | #:description "`symbols` is equivalent to `or/c` and exists for backwards compatibility." 30 | #:literals (symbols) 31 | (symbols sym ...) 32 | (or/c sym ...)) 33 | 34 | 35 | (define-refactoring-rule vector-immutableof-migration 36 | #:description "`vector-immutableof` is a legacy form that is equivalent to `vectorof` with the\ 37 | `#:immutable` option" 38 | #:literals (vector-immutableof) 39 | (vector-immutableof c) 40 | (vectorof c #:immutable #true)) 41 | 42 | 43 | (define-refactoring-rule vector-immutable/c-migration 44 | #:description "`vector-immutable/c` is a legacy form that is equivalent to `vector/c` with the\ 45 | `#:immutable` option" 46 | #:literals (vector-immutable/c) 47 | (vector-immutable/c c ...) 48 | (vector/c c ... #:immutable #true)) 49 | 50 | 51 | (define-refactoring-rule box-immutable/c-migration 52 | #:description "`box-immutable/c` is a legacy form that is equivalent to `box/c` with the\ 53 | `#:immutable` option" 54 | #:literals (box-immutable/c) 55 | (box-immutable/c c) 56 | (box/c c #:immutable #true)) 57 | 58 | 59 | (define-refactoring-rule flat-contract-migration 60 | #:description "flat-contract is a legacy form for constructing contracts from predicates;\ 61 | predicates can be used directly as contracts now." 62 | #:literals (flat-contract) 63 | (flat-contract predicate) 64 | predicate) 65 | 66 | 67 | (define-refactoring-rule contract-struct-migration 68 | #:description "The `contract-struct` form is deprecated; use `struct` instead. Lazy struct\ 69 | contracts no longer require a separate struct declaration." 70 | #:literals (contract-struct) 71 | (contract-struct id fields) 72 | (struct id fields)) 73 | 74 | 75 | (define-refactoring-rule define-contract-struct-migration 76 | #:description "The `define-contract-struct` form is deprecated, use `struct` instead. Lazy struct\ 77 | contracts no longer require a separate struct declaration." 78 | #:literals (define-contract-struct) 79 | (define-contract-struct id fields) 80 | #:with make-id (format-id #'id "make-~a" #'id) 81 | (struct id fields #:extra-constructor-name make-id)) 82 | 83 | 84 | (define-refactoring-rule predicate/c-migration 85 | #:description 86 | "The `predicate/c` contract is less clear than a `->` contract and no longer improves performance." 87 | #:literals (predicate/c) 88 | predicate/c 89 | (-> any/c boolean?)) 90 | 91 | 92 | (define-refactoring-suite legacy-contract-migrations 93 | #:rules (box-immutable/c-migration 94 | contract-struct-migration 95 | define-contract-struct-migration 96 | false/c-migration 97 | flat-contract-migration 98 | predicate/c-migration 99 | symbols-migration 100 | vector-immutableof-migration 101 | vector-immutable/c-migration)) 102 | -------------------------------------------------------------------------------- /default-recommendations/legacy-struct-migrations-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations legacy-struct-migrations 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "define-struct without options" 12 | - (define-struct point (x y)) 13 | - (struct point (x y) #:extra-constructor-name make-point) 14 | 15 | 16 | test: "define-struct with simple options" 17 | - (define-struct point (x y) #:transparent #:mutable) 18 | - (struct point (x y) #:transparent #:mutable #:extra-constructor-name make-point) 19 | 20 | 21 | test: "define-struct with supertype" 22 | ---------------------------------------- 23 | (struct point ()) 24 | (define-struct (2d-point point) (x y)) 25 | ---------------------------------------- 26 | ---------------------------------------- 27 | (struct point ()) 28 | (struct 2d-point point (x y) #:extra-constructor-name make-2d-point) 29 | ---------------------------------------- 30 | 31 | 32 | test: "define-struct with multi-form single-line options" 33 | ---------------------------------------- 34 | (define-struct point (x y) 35 | #:guard (λ (x y _) (values x y)) 36 | #:property prop:custom-print-quotable 37 | 'never 38 | #:inspector #false) 39 | ---------------------------------------- 40 | ---------------------------------------- 41 | (struct point (x y) 42 | #:guard (λ (x y _) (values x y)) 43 | #:property prop:custom-print-quotable 44 | 'never 45 | #:inspector #false 46 | #:extra-constructor-name make-point) 47 | ---------------------------------------- 48 | 49 | 50 | test: "define-struct with multi-line options" 51 | ---------------------------------------- 52 | (define-struct point (x y) 53 | #:property prop:custom-write 54 | (λ (this out mode) (write-string "#" out))) 55 | ---------------------------------------- 56 | ---------------------------------------- 57 | (struct point (x y) 58 | #:property prop:custom-write 59 | (λ (this out mode) (write-string "#" out)) 60 | #:extra-constructor-name make-point) 61 | ---------------------------------------- 62 | 63 | 64 | test: "define-struct with options with separating whitespace" 65 | ---------------------------------------- 66 | (define-struct point (x y) 67 | 68 | #:property prop:custom-write 69 | (λ (this out mode) (write-string "#" out)) 70 | 71 | #:guard (λ (x y _) (values x y))) 72 | ---------------------------------------- 73 | ---------------------------------------- 74 | (struct point (x y) 75 | 76 | #:property prop:custom-write 77 | (λ (this out mode) (write-string "#" out)) 78 | 79 | #:guard (λ (x y _) (values x y)) 80 | #:extra-constructor-name make-point) 81 | ---------------------------------------- 82 | 83 | 84 | test: "define-struct with field comments" 85 | ---------------------------------------- 86 | (define-struct point 87 | (x ;; The X coordinate of the point 88 | y ;; The Y coordinate of the point 89 | )) 90 | ---------------------------------------- 91 | ---------------------------------------- 92 | (struct point 93 | (x ;; The X coordinate of the point 94 | y ;; The Y coordinate of the point 95 | ) 96 | #:extra-constructor-name make-point) 97 | ---------------------------------------- 98 | 99 | 100 | test: "define-struct with comments between options" 101 | ---------------------------------------- 102 | (define-struct point (x y) 103 | 104 | ;; Custom write implementation 105 | #:property prop:custom-write 106 | (λ (this out mode) (write-string "#" out)) 107 | 108 | ;; Field guard 109 | #:guard (λ (x y _) (values x y))) 110 | ---------------------------------------- 111 | ---------------------------------------- 112 | (struct point (x y) 113 | 114 | ;; Custom write implementation 115 | #:property prop:custom-write 116 | (λ (this out mode) (write-string "#" out)) 117 | 118 | ;; Field guard 119 | #:guard (λ (x y _) (values x y)) 120 | #:extra-constructor-name make-point) 121 | ---------------------------------------- 122 | -------------------------------------------------------------------------------- /default-recommendations/legacy-struct-migrations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [legacy-struct-migrations refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/syntax 14 | rebellion/private/static-name 15 | resyntax/base 16 | resyntax/private/syntax-replacement 17 | syntax/parse) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define-syntax-class id-maybe-super 24 | #:attributes (make-id [migrated 1]) 25 | 26 | (pattern id:id 27 | #:with (migrated ...) #'(id) 28 | #:with make-id (format-id #'id "make-~a" #'id)) 29 | 30 | (pattern (id:id super-id:id) 31 | #:with (migrated ...) #'(id super-id) 32 | #:with make-id (format-id #'id "make-~a" #'id))) 33 | 34 | 35 | (define-syntax-class constructor-name-keyword 36 | (pattern (~or #:constructor-name #:extra-constructor-name))) 37 | 38 | 39 | (define-splicing-syntax-class struct-option 40 | #:attributes (keyword [expr 1] [original 1]) 41 | (pattern (~seq (~and keyword:keyword (~not :constructor-name-keyword)) expr:expr ...) 42 | #:with (original ...) #'(keyword expr ...))) 43 | 44 | 45 | (define-refactoring-rule define-struct-to-struct 46 | #:description "The `define-struct` form exists for backwards compatibility, `struct` is preferred." 47 | #:literals (define-struct) 48 | (define-struct id:id-maybe-super fields option:struct-option ...) 49 | (struct id.migrated ... fields option.original ... ... 50 | #:extra-constructor-name id.make-id)) 51 | 52 | 53 | (define-refactoring-suite legacy-struct-migrations 54 | #:rules (define-struct-to-struct)) 55 | -------------------------------------------------------------------------------- /default-recommendations/legacy-syntax-migrations-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations legacy-syntax-migrations 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "the fifth argument to datum->syntax can be removed" 12 | ------------------------------ 13 | (define stx #'foo) 14 | (datum->syntax stx 'bar stx stx #'blah) 15 | ------------------------------ 16 | ------------------------------ 17 | (define stx #'foo) 18 | (datum->syntax stx 'bar stx stx) 19 | ------------------------------ 20 | 21 | 22 | test: "syntax-recertify can be removed" 23 | ------------------------------ 24 | (define stx #'foo) 25 | (define old-stx #'bar) 26 | (syntax-recertify stx old-stx (current-inspector) 'key) 27 | ------------------------------ 28 | ------------------------------ 29 | (define stx #'foo) 30 | (define old-stx #'bar) 31 | stx 32 | ------------------------------ 33 | 34 | 35 | test: "syntax-disarm can be removed" 36 | ------------------------------ 37 | (define stx #'foo) 38 | (syntax-disarm stx (current-inspector)) 39 | ------------------------------ 40 | ------------------------------ 41 | (define stx #'foo) 42 | stx 43 | ------------------------------ 44 | 45 | 46 | test: "syntax-rearm can be removed" 47 | ------------------------------ 48 | (define stx #'foo) 49 | (syntax-rearm stx #'bar) 50 | ------------------------------ 51 | ------------------------------ 52 | (define stx #'foo) 53 | stx 54 | ------------------------------ 55 | 56 | 57 | test: "syntax-protect can be removed" 58 | ------------------------------ 59 | (define stx #'foo) 60 | (syntax-protect stx) 61 | ------------------------------ 62 | ------------------------------ 63 | (define stx #'foo) 64 | stx 65 | ------------------------------ 66 | 67 | 68 | test: "for-clause-syntax-protect can be removed" 69 | ------------------------------ 70 | (require (for-template racket/base)) 71 | (define stx #'foo) 72 | (for-clause-syntax-protect stx) 73 | ------------------------------ 74 | ------------------------------ 75 | (require (for-template racket/base)) 76 | (define stx #'foo) 77 | stx 78 | ------------------------------ 79 | 80 | 81 | test: "syntax-local-match-introduce replaced with syntax-local-introduce" 82 | ------------------------------ 83 | (require (for-template racket/match)) 84 | (define (f) 85 | (syntax-local-match-introduce #'foo)) 86 | ------------------------------ 87 | ------------------------------ 88 | (require (for-template racket/match)) 89 | (define (f) 90 | (syntax-local-introduce #'foo)) 91 | ------------------------------ 92 | 93 | 94 | test: "syntax-local-provide-introduce replaced with syntax-local-introduce" 95 | ------------------------------ 96 | (require (for-template racket/provide-syntax)) 97 | (define (f) 98 | (syntax-local-provide-introduce #'foo)) 99 | ------------------------------ 100 | ------------------------------ 101 | (require (for-template racket/provide-syntax)) 102 | (define (f) 103 | (syntax-local-introduce #'foo)) 104 | ------------------------------ 105 | 106 | 107 | test: "syntax-local-require-introduce replaced with syntax-local-introduce" 108 | ------------------------------ 109 | (require (for-template racket/require-syntax)) 110 | (define (f) 111 | (syntax-local-require-introduce #'foo)) 112 | ------------------------------ 113 | ------------------------------ 114 | (require (for-template racket/require-syntax)) 115 | (define (f) 116 | (syntax-local-introduce #'foo)) 117 | ------------------------------ 118 | 119 | 120 | test: "syntax-local-syntax-parse-pattern-introduce replaced with syntax-local-introduce" 121 | ------------------------------ 122 | (require (for-template syntax/parse)) 123 | (define (f) 124 | (syntax-local-syntax-parse-pattern-introduce #'foo)) 125 | ------------------------------ 126 | ------------------------------ 127 | (require (for-template syntax/parse)) 128 | (define (f) 129 | (syntax-local-introduce #'foo)) 130 | ------------------------------ 131 | -------------------------------------------------------------------------------- /default-recommendations/legacy-syntax-migrations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [legacy-syntax-migrations refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | (for-template racket/base 14 | racket/match 15 | racket/provide-syntax 16 | racket/require-syntax 17 | syntax/parse) 18 | rebellion/private/static-name 19 | resyntax/base 20 | resyntax/private/syntax-neighbors 21 | resyntax/private/syntax-replacement 22 | syntax/parse) 23 | 24 | 25 | ;@---------------------------------------------------------------------------------------------------- 26 | 27 | 28 | (define-refactoring-rule datum->syntax-migration 29 | #:description "The fifth argument to `datum->syntax` is ignored." 30 | #:literals (datum->syntax) 31 | ((~and id datum->syntax) ctxt v srcloc prop ignored) 32 | (id ctxt v srcloc prop)) 33 | 34 | 35 | (define-refactoring-rule syntax-recertify-migration 36 | #:description "The `syntax-recertify` function is a legacy function that does nothing." 37 | #:literals (syntax-recertify) 38 | (syntax-recertify stx _ _ _) 39 | stx) 40 | 41 | 42 | (define-refactoring-rule syntax-disarm-migration 43 | #:description "The `syntax-disarm` function is a legacy function that does nothing." 44 | #:literals (syntax-disarm) 45 | (syntax-disarm stx _) 46 | stx) 47 | 48 | 49 | (define-refactoring-rule syntax-rearm-migration 50 | #:description "The `syntax-rearm` function is a legacy function that does nothing." 51 | #:literals (syntax-rearm) 52 | (syntax-rearm stx _ ...) 53 | stx) 54 | 55 | 56 | (define-refactoring-rule syntax-protect-migration 57 | #:description "The `syntax-protect` function is a legacy function that does nothing." 58 | #:literals (syntax-protect) 59 | (syntax-protect stx) 60 | stx) 61 | 62 | 63 | (define-refactoring-rule for-clause-syntax-protect-migration 64 | #:description "The `for-clause-syntax-protect` function is a legacy function that does nothing." 65 | #:literals (for-clause-syntax-protect) 66 | (for-clause-syntax-protect stx) 67 | stx) 68 | 69 | 70 | (define-refactoring-rule syntax-local-match-introduce-migration 71 | #:description 72 | "The `syntax-local-match-introduce` function is a legacy function that's equivalent to\ 73 | `syntax-local-introduce`." 74 | #:literals (syntax-local-match-introduce) 75 | (id:syntax-local-match-introduce stx) 76 | ((~replacement syntax-local-introduce #:original id) stx)) 77 | 78 | 79 | (define-refactoring-rule syntax-local-provide-introduce-migration 80 | #:description 81 | "The `syntax-local-provide-introduce` function is a legacy function that's equivalent to\ 82 | `syntax-local-introduce`." 83 | #:literals (syntax-local-provide-introduce) 84 | (id:syntax-local-provide-introduce stx) 85 | ((~replacement syntax-local-introduce #:original id) stx)) 86 | 87 | 88 | (define-refactoring-rule syntax-local-require-introduce-migration 89 | #:description 90 | "The `syntax-local-require-introduce` function is a legacy function that's equivalent to\ 91 | `syntax-local-introduce`." 92 | #:literals (syntax-local-require-introduce) 93 | (id:syntax-local-require-introduce stx) 94 | ((~replacement syntax-local-introduce #:original id) stx)) 95 | 96 | 97 | (define-refactoring-rule syntax-local-syntax-parse-pattern-introduce-migration 98 | #:description 99 | "The `syntax-local-syntax-parse-pattern-introduce` function is a legacy function that's equivalent\ 100 | to `syntax-local-introduce`." 101 | #:literals (syntax-local-syntax-parse-pattern-introduce) 102 | (id:syntax-local-syntax-parse-pattern-introduce stx) 103 | ((~replacement syntax-local-introduce #:original id) stx)) 104 | 105 | 106 | (define-refactoring-suite legacy-syntax-migrations 107 | #:rules (datum->syntax-migration 108 | for-clause-syntax-protect-migration 109 | syntax-disarm-migration 110 | syntax-local-match-introduce-migration 111 | syntax-local-provide-introduce-migration 112 | syntax-local-require-introduce-migration 113 | syntax-local-syntax-parse-pattern-introduce-migration 114 | syntax-protect-migration 115 | syntax-rearm-migration 116 | syntax-recertify-migration)) 117 | -------------------------------------------------------------------------------- /default-recommendations/let-binding-suggestions-comment-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations let-binding-suggestions 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "let binding with commented right-hand-side expression" 12 | ------------------------------ 13 | (define (f) 14 | (let ([x 15 | ;; The number one 16 | 1]) 17 | x)) 18 | ------------------------------ 19 | ------------------------------ 20 | (define (f) 21 | (define x 22 | ;; The number one 23 | 1) 24 | x) 25 | ------------------------------ 26 | 27 | test: "let binding with commented second clause" 28 | ------------------------------ 29 | (define (f) 30 | (let ([x 1] 31 | ;; The number two 32 | [y 2]) 33 | (+ x y))) 34 | ------------------------------ 35 | ------------------------------ 36 | (define (f) 37 | (define x 1) 38 | ;; The number two 39 | (define y 2) 40 | (+ x y)) 41 | ------------------------------ 42 | 43 | 44 | test: "let binding with commented first clause not refactorable (yet)" 45 | ------------------------------ 46 | (define (f) 47 | (let (;; The number one 48 | [x 1]) 49 | x)) 50 | ------------------------------ 51 | 52 | 53 | test: "let binding with commented first body form refactorable" 54 | ------------------------------ 55 | (define (f) 56 | (let ([x 1]) 57 | ;; Comment 58 | (void) 59 | x)) 60 | ------------------------------ 61 | ------------------------------ 62 | (define (f) 63 | (define x 1) 64 | ;; Comment 65 | (void) 66 | x) 67 | ------------------------------ 68 | 69 | 70 | test: "let binding with commented second body form refactorable" 71 | ------------------------------ 72 | (define (f) 73 | (let ([x 1]) 74 | (void) 75 | ;; Comment 76 | x)) 77 | ------------------------------ 78 | ------------------------------ 79 | (define (f) 80 | (define x 1) 81 | (void) 82 | ;; Comment 83 | x) 84 | ------------------------------ 85 | 86 | 87 | test: "let binding with comments before let form refactorable" 88 | ------------------------------ 89 | (define (f) 90 | ;; Comment 91 | (void) 92 | ;; Comment 93 | (let ([x 1]) 94 | x)) 95 | ------------------------------ 96 | ------------------------------ 97 | (define (f) 98 | ;; Comment 99 | (void) 100 | ;; Comment 101 | (define x 1) 102 | x) 103 | ------------------------------ 104 | -------------------------------------------------------------------------------- /default-recommendations/let-binding-suggestions-function-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations let-binding-suggestions 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "let binding to lambda" 12 | ------------------------------ 13 | (define (f) 14 | (let ([g (λ (x y) 1)]) 15 | g)) 16 | ------------------------------ 17 | ------------------------------ 18 | (define (f) 19 | (define (g x y) 20 | 1) 21 | g) 22 | ------------------------------ 23 | 24 | 25 | test: "let binding to lambda with keyword args" 26 | ------------------------------ 27 | (define (f) 28 | (let ([g (λ (#:x x #:y y) 1)]) 29 | g)) 30 | ------------------------------ 31 | ------------------------------ 32 | (define (f) 33 | (define (g #:x x #:y y) 34 | 1) 35 | g) 36 | ------------------------------ 37 | 38 | 39 | test: "let binding to lambda with optional args" 40 | ------------------------------ 41 | (define (f) 42 | (let ([g (λ ([x 1] [y 1]) 1)]) 43 | g)) 44 | ------------------------------ 45 | ------------------------------ 46 | (define (f) 47 | (define (g [x 1] [y 1]) 48 | 1) 49 | g) 50 | ------------------------------ 51 | 52 | 53 | test: "let binding to lambda with only rest args" 54 | ------------------------------ 55 | (define (f) 56 | (let ([g (λ xs 1)]) 57 | g)) 58 | ------------------------------ 59 | ------------------------------ 60 | (define (f) 61 | (define (g . xs) 62 | 1) 63 | g) 64 | ------------------------------ 65 | 66 | 67 | test: "let binding to lambda with positional and rest args" 68 | ------------------------------ 69 | (define (f) 70 | (let ([g (λ (x y . zs) 1)]) 71 | g)) 72 | ------------------------------ 73 | ------------------------------ 74 | (define (f) 75 | (define (g x y . zs) 76 | 1) 77 | g) 78 | ------------------------------ 79 | -------------------------------------------------------------------------------- /default-recommendations/let-binding-suggestions-nesting-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations let-binding-suggestions 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "nested let bindings" 12 | ------------------------------ 13 | (define (f) 14 | (let ([x 1]) 15 | (let ([y 1]) 16 | (let ([z 1]) 17 | (+ x y z))))) 18 | ------------------------------ 19 | ------------------------------ 20 | (define (f) 21 | (define x 1) 22 | (define y 1) 23 | (define z 1) 24 | (+ x y z)) 25 | ------------------------------ 26 | 27 | 28 | test: "nested let bindings with interleaved expressions" 29 | ------------------------------ 30 | (define (f) 31 | (let ([x 1]) 32 | (displayln "foo") 33 | (let ([y 1]) 34 | (displayln "bar") 35 | (let ([z 1]) 36 | (+ x y z))))) 37 | ------------------------------ 38 | ------------------------------ 39 | (define (f) 40 | (define x 1) 41 | (displayln "foo") 42 | (define y 1) 43 | (displayln "bar") 44 | (define z 1) 45 | (+ x y z)) 46 | ------------------------------ 47 | 48 | 49 | test: "nested conflicting let bindings only partially refactorable" 50 | ------------------------------ 51 | (define (f) 52 | (let ([x 1]) 53 | (displayln x) 54 | (let ([x 2]) 55 | x))) 56 | ------------------------------ 57 | ------------------------------ 58 | (define (f) 59 | (define x 1) 60 | (displayln x) 61 | (let ([x 2]) x)) 62 | ------------------------------ 63 | -------------------------------------------------------------------------------- /default-recommendations/let-binding-suggestions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [let-binding-suggestions refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/set 14 | rebellion/private/static-name 15 | resyntax/base 16 | resyntax/default-recommendations/private/definition-context 17 | resyntax/default-recommendations/private/lambda-by-any-name 18 | resyntax/default-recommendations/private/let-binding 19 | resyntax/default-recommendations/private/syntax-equivalence 20 | resyntax/default-recommendations/private/syntax-identifier-sets 21 | resyntax/private/syntax-neighbors 22 | resyntax/private/syntax-replacement 23 | syntax/id-set 24 | syntax/parse 25 | (only-in racket/class 26 | define/augment 27 | define/augment-final 28 | define/augride 29 | define/overment 30 | define/override 31 | define/override-final 32 | define/public 33 | define/public-final 34 | define/pubment 35 | define/private)) 36 | 37 | 38 | ;@---------------------------------------------------------------------------------------------------- 39 | 40 | 41 | (define-definition-context-refactoring-rule let-to-define 42 | #:description 43 | "Internal definitions are recommended instead of `let` expressions, to reduce nesting." 44 | (~seq leading-body ... let-expression:refactorable-let-expression) 45 | #:with (replacement ...) #'(~focus-replacement-on (let-expression.refactored ...)) 46 | (leading-body ... replacement ...)) 47 | 48 | 49 | (define-refactoring-rule named-let-to-plain-let 50 | #:description 51 | "This named `let` loop doesn't actually perform any recursive calls, and can be replaced with an\ 52 | unnamed `let`." 53 | #:literals (let) 54 | (let name:id header body ...) 55 | #:when (not (set-member? (syntax-free-identifiers #'(body ...)) #'name)) 56 | (let header body ...)) 57 | 58 | 59 | (define-refactoring-rule let-values-then-call-to-call-with-values 60 | #:description 61 | "This `let-values` expression can be replaced with a simpler, equivalent `call-with-values`\ 62 | expression." 63 | #:literals (let-values) 64 | (let-values ([(bound-id:id ...+) expr]) 65 | (receiver:id arg-id:id ...+)) 66 | #:when (syntax-free-identifier=? #'(bound-id ...) #'(arg-id ...)) 67 | (call-with-values (λ () expr) receiver)) 68 | 69 | 70 | (define-definition-context-refactoring-rule define-let-to-double-define 71 | #:description "This `let` expression can be pulled up into a `define` expression." 72 | #:literals (define let) 73 | (~seq body-before ... 74 | (~and original-definition (define id:id (let ([nested-id:id nested-expr:expr]) expr:expr))) 75 | body-after ...) 76 | #:when (identifier-binding-unchanged-in-context? (attribute id) (attribute nested-expr)) 77 | #:when (for/and ([body-free-id 78 | (in-free-id-set 79 | (syntax-free-identifiers #'(body-before ... nested-expr body-after ...)))]) 80 | (identifier-binding-unchanged-in-context? body-free-id (attribute nested-id))) 81 | (body-before ... 82 | (~@ . (~focus-replacement-on 83 | (~splicing-replacement ((define nested-id nested-expr) (define id expr)) 84 | #:original original-definition))) 85 | body-after ...)) 86 | 87 | 88 | (define-definition-context-refactoring-rule begin0-let-to-define-begin0 89 | #:description 90 | "The `let` expression in this `begin0` form can be extracted into the surrounding definition\ 91 | context." 92 | #:literals (begin0 let) 93 | (~seq body-before ... 94 | (begin0 95 | (~and original-let (let ([nested-id:id nested-expr:expr]) let-body ... result-expr:expr)) 96 | body-after ...)) 97 | #:when (not 98 | (set-member? (syntax-bound-identifiers #'(body-before ... body-after ...)) #'nested-id)) 99 | (body-before ... 100 | (define nested-id nested-expr) 101 | let-body ... 102 | (begin0 (~replacement result-expr #:original original-let) body-after ...))) 103 | 104 | 105 | (define-refactoring-rule delete-redundant-let 106 | #:description "This `let` binding does nothing and can be removed." 107 | #:literals (let) 108 | (let ([left-id:id right-id:id]) body) 109 | #:when (equal? (syntax-e (attribute left-id)) (syntax-e (attribute right-id))) 110 | body) 111 | 112 | 113 | (define-refactoring-suite let-binding-suggestions 114 | #:rules (let-to-define 115 | begin0-let-to-define-begin0 116 | define-let-to-double-define 117 | delete-redundant-let 118 | let-values-then-call-to-call-with-values 119 | named-let-to-plain-let)) 120 | -------------------------------------------------------------------------------- /default-recommendations/match-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations match-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (require racket/match) 11 | ------------------------------ 12 | 13 | 14 | test: "single-clause match expressions can be replaced with match-define expressions" 15 | ------------------------------ 16 | (define (foo x) 17 | (displayln "foo?") 18 | (match x 19 | [(list a b c) 20 | (displayln "foo!") 21 | (+ a b c)])) 22 | ------------------------------ 23 | ------------------------------ 24 | (define (foo x) 25 | (displayln "foo?") 26 | (match-define (list a b c) x) 27 | (displayln "foo!") 28 | (+ a b c)) 29 | ------------------------------ 30 | 31 | 32 | test: "migrating single-clause match expressions to match-define doesn't reformat context" 33 | ------------------------------ 34 | (define (foo x) 35 | 36 | ( displayln "foo?" ) 37 | 38 | (match x 39 | [(list a b c) 40 | (displayln "foo!") 41 | (+ a b c)])) 42 | ------------------------------ 43 | ------------------------------ 44 | (define (foo x) 45 | 46 | ( displayln "foo?" ) 47 | 48 | (match-define (list a b c) x) 49 | (displayln "foo!") 50 | (+ a b c)) 51 | ------------------------------ 52 | 53 | 54 | test: "migrating single-clause match expressions in single-form contexts does reformat" 55 | ------------------------------ 56 | (map (λ (x) (match x [(list a b c) (+ a b c)])) 57 | (list (list 1 2 3) (list 4 5 6))) 58 | ------------------------------ 59 | ------------------------------ 60 | (map (λ (x) 61 | (match-define (list a b c) x) 62 | (+ a b c)) 63 | (list (list 1 2 3) (list 4 5 6))) 64 | ------------------------------ 65 | 66 | 67 | test: "single-clause match expressions inside cond can be replaced with match-define expressions" 68 | ------------------------------ 69 | (define (foo x condition) 70 | (cond 71 | [condition 72 | (displayln "foo?") 73 | (match x 74 | [(list a b c) 75 | (displayln "foo!") 76 | (+ a b c)])] 77 | [else (displayln "else")])) 78 | ------------------------------ 79 | ------------------------------ 80 | (define (foo x condition) 81 | (cond 82 | [condition 83 | (displayln "foo?") 84 | (match-define (list a b c) x) 85 | (displayln "foo!") 86 | (+ a b c)] 87 | [else (displayln "else")])) 88 | ------------------------------ 89 | -------------------------------------------------------------------------------- /default-recommendations/match-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [match-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require racket/list 13 | racket/match 14 | racket/set 15 | resyntax/base 16 | resyntax/default-recommendations/private/syntax-identifier-sets 17 | syntax/parse) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define-syntax-class single-clause-match 24 | #:literals (match) 25 | #:attributes (match-pattern [as-definition-context-body 1]) 26 | 27 | (pattern (match subject [match-pattern body ...]) 28 | #:with definition #'(match-define match-pattern subject) 29 | #:with (as-definition-context-body ...) 30 | #`(~splicing-replacement (definition body ...) #:original #,this-syntax))) 31 | 32 | 33 | (define-definition-context-refactoring-rule single-clause-match-to-match-define 34 | #:description "This `match` expression can be simplified using `match-define`." 35 | #:literals (match) 36 | (~seq body-before ... match-expression:single-clause-match) 37 | #:when (set-empty? (set-intersect (syntax-bound-identifiers #'(body-before ...)) 38 | (syntax-bound-identifiers #'match-expression.match-pattern))) 39 | #:with (new-body ...) (if (empty? (attribute body-before)) 40 | (attribute match-expression.as-definition-context-body) 41 | #'(~focus-replacement-on 42 | (match-expression.as-definition-context-body ...))) 43 | (body-before ... new-body ...)) 44 | 45 | 46 | (define-refactoring-suite match-shortcuts 47 | #:rules (single-clause-match-to-match-define)) 48 | -------------------------------------------------------------------------------- /default-recommendations/miscellaneous-suggestions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [miscellaneous-suggestions refactoring-suite?])) 10 | 11 | 12 | (require (for-syntax racket/base) 13 | racket/match 14 | rebellion/private/static-name 15 | resyntax/base 16 | resyntax/private/syntax-replacement 17 | syntax/parse) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define if-begin-to-cond-message 24 | "The `cond` form supports multiple body expressions in each branch, making `begin` unnecessary.") 25 | 26 | (define-refactoring-rule if-then-begin-to-cond 27 | #:description if-begin-to-cond-message 28 | #:literals (if begin) 29 | (if condition (begin then-body ...) else-branch) 30 | (cond [condition then-body ...] [else else-branch])) 31 | 32 | 33 | (define-refactoring-rule if-else-begin-to-cond 34 | #:description if-begin-to-cond-message 35 | #:literals (if begin) 36 | (if condition then-branch (begin else-body ...)) 37 | (cond [condition then-branch] [else else-body ...])) 38 | 39 | 40 | (define-refactoring-rule if-else-cond-to-cond 41 | #:description if-begin-to-cond-message 42 | #:literals (if cond) 43 | (if condition then-branch (cond clause ...)) 44 | (cond [condition then-branch] clause ...)) 45 | 46 | 47 | (define-refactoring-rule cond-else-if-to-cond 48 | #:description "The `else`-`if` branch of this `cond` expression can be collapsed into the `cond`\ 49 | expression." 50 | #:literals (cond else if) 51 | (cond clause ... [else (if inner-condition inner-then-branch else-branch)]) 52 | (cond clause ... [inner-condition inner-then-branch] [else else-branch])) 53 | 54 | 55 | (define-refactoring-rule cond-begin-to-cond 56 | #:description "The bodies of `cond` clauses are already implicitly wrapped in `begin`." 57 | #:literals (cond begin) 58 | (cond clause-before ... [condition (begin body ...)] clause-after ...) 59 | (cond clause-before ... [condition body ...] clause-after ...)) 60 | 61 | 62 | (define-refactoring-rule and-match-to-match 63 | #:description "This `and` expression can be turned into a clause of the inner `match` expression,\ 64 | reducing nesting." 65 | #:literals (and match) 66 | (and and-subject:id (match match-subject:id match-clause ...)) 67 | #:when (free-identifier=? #'and-subject #'match-subject) 68 | (match match-subject [#false #false] match-clause ...)) 69 | 70 | 71 | (define-refactoring-suite miscellaneous-suggestions 72 | #:rules (and-match-to-match 73 | cond-begin-to-cond 74 | cond-else-if-to-cond 75 | if-then-begin-to-cond 76 | if-else-begin-to-cond 77 | if-else-cond-to-cond)) 78 | -------------------------------------------------------------------------------- /default-recommendations/numeric-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations numeric-shortcuts 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "lambda equivalent to add1 refactorable to add1" 12 | - (map (λ (x) (+ x 1)) (list 1 2 3)) 13 | - (map (λ (x) (+ 1 x)) (list 1 2 3)) 14 | - (map add1 (list 1 2 3)) 15 | 16 | 17 | test: "lambda equivalent to sub1 refactorable to sub1" 18 | - (map (λ (x) (- x 1)) (list 1 2 3)) 19 | - (map (λ (x) (+ x -1)) (list 1 2 3)) 20 | - (map (λ (x) (+ -1 x)) (list 1 2 3)) 21 | - (map sub1 (list 1 2 3)) 22 | 23 | 24 | test: "lambda equivalent to positive? refactorable to positive?" 25 | - (filter (λ (x) (> x 0)) (list -2 -1 0 1 2)) 26 | - (filter (λ (x) (< 0 x)) (list -2 -1 0 1 2)) 27 | - (filter (λ (x) (not (<= x 0))) (list -2 -1 0 1 2)) 28 | - (filter (λ (x) (not (>= 0 x))) (list -2 -1 0 1 2)) 29 | - (filter positive? (list -2 -1 0 1 2)) 30 | 31 | 32 | test: "lambda equivalent to negative? refactorable to negative?" 33 | - (filter (λ (x) (< x 0)) (list -2 -1 0 1 2)) 34 | - (filter (λ (x) (> 0 x)) (list -2 -1 0 1 2)) 35 | - (filter (λ (x) (not (>= x 0))) (list -2 -1 0 1 2)) 36 | - (filter (λ (x) (not (<= 0 x))) (list -2 -1 0 1 2)) 37 | - (filter negative? (list -2 -1 0 1 2)) 38 | 39 | 40 | test: "addition of a single term is identity" 41 | - (+ 1) 42 | - 1 43 | 44 | 45 | test: "multiplication of a single term is identity" 46 | - (* 512) 47 | - 512 48 | -------------------------------------------------------------------------------- /default-recommendations/numeric-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [numeric-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require rebellion/private/static-name 13 | resyntax/base 14 | resyntax/default-recommendations/private/lambda-by-any-name 15 | syntax/parse) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-refactoring-rule add1-lambda-to-add1 22 | #:description "This lambda function is equivalent to the built-in `add1` function." 23 | #:literals (+) 24 | (lambda:lambda-by-any-name (x1:id) (~or (+ x2:id 1) (+ 1 x2:id))) 25 | #:when (free-identifier=? #'x1 #'x2) 26 | add1) 27 | 28 | 29 | (define-refactoring-rule sub1-lambda-to-sub1 30 | #:description "This lambda function is equivalent to the built-in `sub1` function." 31 | #:literals (+ -) 32 | (lambda:lambda-by-any-name (x1:id) (~or (- x2:id 1) (+ x2:id -1) (+ -1 x2:id))) 33 | #:when (free-identifier=? #'x1 #'x2) 34 | sub1) 35 | 36 | 37 | (define-refactoring-rule zero-comparison-lambda-to-positive? 38 | #:description "This lambda function is equivalent to the built-in `positive?` predicate." 39 | #:literals (< > <= >= not) 40 | (lambda:lambda-by-any-name (x1:id) 41 | (~or (> x2:id 0) 42 | (< 0 x2:id) 43 | (not (<= x2:id 0)) 44 | (not (>= 0 x2:id)))) 45 | #:when (free-identifier=? #'x1 #'x2) 46 | positive?) 47 | 48 | 49 | (define-refactoring-rule zero-comparison-lambda-to-negative? 50 | #:description "This lambda function is equivalent to the built-in `negative?` predicate." 51 | #:literals (< > <= >= not) 52 | (lambda:lambda-by-any-name (x1:id) 53 | (~or (< x2:id 0) 54 | (> 0 x2:id) 55 | (not (>= x2:id 0)) 56 | (not (<= 0 x2:id)))) 57 | #:when (free-identifier=? #'x1 #'x2) 58 | negative?) 59 | 60 | 61 | (define-refactoring-rule single-argument-plus-to-identity 62 | #:description "This expression is equivalent to the identity." 63 | #:literals (+) 64 | (+ e) 65 | e) 66 | 67 | 68 | (define-refactoring-rule single-argument-multiply-to-identity 69 | #:description "This expression is equivalent to the identity." 70 | #:literals (*) 71 | (* e) 72 | e) 73 | 74 | 75 | (define-refactoring-suite numeric-shortcuts 76 | #:rules (add1-lambda-to-add1 77 | single-argument-multiply-to-identity 78 | single-argument-plus-to-identity 79 | sub1-lambda-to-sub1 80 | zero-comparison-lambda-to-negative? 81 | zero-comparison-lambda-to-positive?)) 82 | -------------------------------------------------------------------------------- /default-recommendations/private/boolean.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide condition-expression 5 | known-false 6 | known-not-false 7 | likely-boolean 8 | if-like-expression) 9 | 10 | 11 | (require racket/string 12 | resyntax/default-recommendations/private/literal-constant 13 | resyntax/default-recommendations/private/metafunction 14 | syntax/parse) 15 | 16 | 17 | (module+ test 18 | (require rackunit 19 | (submod ".."))) 20 | 21 | 22 | ;@---------------------------------------------------------------------------------------------------- 23 | 24 | 25 | (define-syntax-class known-false 26 | (pattern constant:literal-constant #:when (not (attribute constant.value)))) 27 | 28 | 29 | (define-syntax-class known-not-false 30 | (pattern constant:literal-constant #:when (attribute constant.value))) 31 | 32 | 33 | (define-syntax-class known-true 34 | (pattern constant:literal-constant #:when (equal? (attribute constant.value) #true))) 35 | 36 | 37 | (define-syntax-class likely-boolean 38 | #:literals (or and not if) 39 | (pattern true:known-true) 40 | (pattern false:known-false) 41 | (pattern (or _:likely-boolean ...)) 42 | (pattern (and _ ... _:likely-boolean)) 43 | (pattern (not _)) 44 | (pattern (f:likely-boolean-returning arg ...)) 45 | (pattern (if _ _:likely-boolean _:likely-boolean))) 46 | 47 | 48 | (define-syntax-class likely-boolean-returning 49 | #:literals (= < > <= >=) 50 | (pattern id:id #:when (string-suffix? (symbol->string (syntax-e #'id)) "?")) 51 | (pattern (~or = < > <= >=))) 52 | 53 | 54 | (define-syntax-class condition-expression 55 | #:attributes (negated? base-condition) 56 | #:literals (not) 57 | (pattern (not base-condition:expr) #:with negated? #true) 58 | (pattern (~and base-condition:expr (~not (not _))) #:with negated? #false)) 59 | 60 | 61 | (define-syntax-class if-like-expression 62 | #:attributes (negated? base-condition [true-body 1] [false-body 1]) 63 | #:literals (if cond else) 64 | 65 | (pattern (if :condition-expression first-branch second-branch) 66 | #:with (true-body ...) #'((~if negated? second-branch first-branch)) 67 | #:with (false-body ...) #'((~if negated? first-branch second-branch))) 68 | 69 | (pattern (cond [:condition-expression first-body ...] [else second-body ...]) 70 | #:with (true-body ...) #'(~if negated? (second-body ...) (first-body ...)) 71 | #:with (false-body ...) #'(~if negated? (first-body ...) (second-body ...))) 72 | 73 | (pattern (cond [:condition-expression first-body ...] [second-branch]) 74 | #:with (true-body ...) #'(~if negated? (second-branch) (first-body ...)) 75 | #:with (false-body ...) #'(~if negated? (first-body ...) (second-branch)))) 76 | 77 | 78 | (module+ test 79 | (test-case "if-like-expression" 80 | 81 | (syntax-parse #'(if (even? n) a b) 82 | [:if-like-expression 83 | (check-false (syntax->datum #'negated?)) 84 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 85 | (check-equal? (syntax->datum #'(true-body ...)) '(a)) 86 | (check-equal? (syntax->datum #'(false-body ...)) '(b))]) 87 | 88 | (syntax-parse #'(if (not (even? n)) a b) 89 | [:if-like-expression 90 | (check-true (syntax->datum #'negated?)) 91 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 92 | (check-equal? (syntax->datum #'(true-body ...)) '(b)) 93 | (check-equal? (syntax->datum #'(false-body ...)) '(a))]) 94 | 95 | (syntax-parse #'(cond [(even? n) a b c] [else x y z]) 96 | [:if-like-expression 97 | (check-false (syntax->datum #'negated?)) 98 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 99 | (check-equal? (syntax->datum #'(true-body ...)) '(a b c)) 100 | (check-equal? (syntax->datum #'(false-body ...)) '(x y z))]) 101 | 102 | (syntax-parse #'(cond [(not (even? n)) a b c] [else x y z]) 103 | [:if-like-expression 104 | (check-true (syntax->datum #'negated?)) 105 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 106 | (check-equal? (syntax->datum #'(true-body ...)) '(x y z)) 107 | (check-equal? (syntax->datum #'(false-body ...)) '(a b c))]) 108 | 109 | (syntax-parse #'(cond [(even? n) a b c] [x]) 110 | [:if-like-expression 111 | (check-false (syntax->datum #'negated?)) 112 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 113 | (check-equal? (syntax->datum #'(true-body ...)) '(a b c)) 114 | (check-equal? (syntax->datum #'(false-body ...)) '(x))]) 115 | 116 | (syntax-parse #'(cond [(not (even? n)) a b c] [x]) 117 | [:if-like-expression 118 | (check-true (syntax->datum #'negated?)) 119 | (check-equal? (syntax->datum #'base-condition) '(even? n)) 120 | (check-equal? (syntax->datum #'(true-body ...)) '(x)) 121 | (check-equal? (syntax->datum #'(false-body ...)) '(a b c))]))) 122 | -------------------------------------------------------------------------------- /default-recommendations/private/exception.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide always-throwing-expression) 5 | 6 | 7 | (require racket/contract/combinator 8 | racket/generic 9 | syntax/parse 10 | syntax/readerr) 11 | 12 | 13 | ;@---------------------------------------------------------------------------------------------------- 14 | 15 | 16 | (define-syntax-class always-throwing-expression 17 | #:literals (raise 18 | error 19 | raise-user-error 20 | raise-argument-error 21 | raise-result-error 22 | raise-arguments-error 23 | raise-range-error 24 | raise-type-error 25 | raise-mismatch-error 26 | raise-arity-error 27 | raise-arity-mask-error 28 | raise-result-arity-error 29 | raise-syntax-error 30 | raise-read-error 31 | raise-read-eof-error 32 | raise-blame-error 33 | raise-support-error) 34 | (pattern ((~or raise 35 | error 36 | raise-user-error 37 | raise-argument-error 38 | raise-result-error 39 | raise-arguments-error 40 | raise-range-error 41 | raise-type-error 42 | raise-mismatch-error 43 | raise-arity-error 44 | raise-arity-mask-error 45 | raise-result-arity-error 46 | raise-syntax-error 47 | raise-read-error 48 | raise-read-eof-error 49 | raise-blame-error 50 | raise-support-error) 51 | arg ...))) 52 | -------------------------------------------------------------------------------- /default-recommendations/private/lambda-by-any-name.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide lambda-by-any-name) 5 | 6 | 7 | (require syntax/parse) 8 | 9 | 10 | ;@---------------------------------------------------------------------------------------------------- 11 | 12 | 13 | ;; λ and lambda aren't free-identifier=?. Additionally, by using a syntax class instead of #:literals 14 | ;; we can produce the same lambda identifier that the input syntax had instead of changing all lambda 15 | ;; identfiers to one of the two cases. There doesn't seem to be a strong community consensus on which 16 | ;; name should be used, so we want to avoid changing the original code's choice. 17 | (define-syntax-class lambda-by-any-name 18 | #:literals (λ lambda) 19 | (pattern (~or λ lambda))) 20 | -------------------------------------------------------------------------------- /default-recommendations/private/literal-constant.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide literal-constant) 5 | 6 | 7 | (require syntax/parse) 8 | 9 | 10 | ;@---------------------------------------------------------------------------------------------------- 11 | 12 | 13 | (define-syntax-class literal-constant 14 | #:attributes (value) 15 | #:literals (quote) 16 | 17 | (pattern 18 | (~or (quote literal) 19 | literal:boolean 20 | literal:character 21 | literal:number 22 | literal:regexp 23 | literal:byte-regexp 24 | literal:string 25 | literal:bytes) 26 | #:attr value (syntax->datum #'literal))) 27 | -------------------------------------------------------------------------------- /default-recommendations/private/metafunction.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide ~if) 5 | 6 | 7 | (require syntax/parse 8 | syntax/parse/experimental/template) 9 | 10 | 11 | (module+ test 12 | (require racket/syntax 13 | rackunit 14 | rebellion/private/static-name 15 | (submod ".."))) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-template-metafunction (~if stx) 22 | (syntax-parse stx 23 | #:track-literals 24 | [(_ condition true false) 25 | (if (syntax-e #'condition) #'true #'false)])) 26 | 27 | 28 | (module+ test 29 | (test-case (name-string ~if) 30 | (define/with-syntax (condition ...) #'(#true #false #false)) 31 | (define/with-syntax a #'foo) 32 | (define/with-syntax b #'bar) 33 | (define stx #'((~if condition a b) ...)) 34 | (check-equal? (syntax->datum stx) '(foo bar bar)))) 35 | -------------------------------------------------------------------------------- /default-recommendations/private/pure-expression.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide pure-expression) 5 | 6 | 7 | (require resyntax/default-recommendations/private/literal-constant 8 | syntax/parse) 9 | 10 | 11 | ;@---------------------------------------------------------------------------------------------------- 12 | 13 | 14 | (define-syntax-class pure-expression 15 | (pattern (~or _:literal-constant _:id))) 16 | -------------------------------------------------------------------------------- /default-recommendations/private/syntax-equivalence.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [syntax-free-identifier=? (-> syntax? syntax? boolean?)])) 10 | 11 | 12 | (require guard 13 | racket/list 14 | racket/match) 15 | 16 | 17 | (module+ test 18 | (require rackunit 19 | (submod ".."))) 20 | 21 | 22 | ;@---------------------------------------------------------------------------------------------------- 23 | 24 | 25 | (define (syntax-free-identifier=? stx other-stx) 26 | (define datum (syntax-e stx)) 27 | (define other-datum (syntax-e other-stx)) 28 | (match datum 29 | [(? symbol?) (and (symbol? other-datum) (free-identifier=? stx other-stx))] 30 | [(? number? boolean? string?) (equal? datum other-datum)] 31 | [(? list?) (and (list? other-datum) (syntax-pair-free-identifier=? datum other-datum))] 32 | [(? box?) (and (box? other-datum) (syntax-free-identifier=? (unbox datum) (unbox other-datum)))] 33 | [(? vector?) 34 | (and (equal? (vector-length datum) (vector-length other-datum)) 35 | (for/and ([substx (in-vector datum)] [other-substx (in-vector other-datum)]) 36 | (syntax-free-identifier=? substx other-substx)))] 37 | [_ (error 'syntax-free-identifier=? "hash datum comparisons not implemented yet.")])) 38 | 39 | 40 | (define (syntax-pair-free-identifier=? pair other-pair) 41 | (match pair 42 | ['() (empty? other-pair)] 43 | [(cons head (? syntax? tail)) 44 | (match other-pair 45 | [(cons other-head (? syntax? other-tail)) 46 | (and (syntax-free-identifier=? head other-head) 47 | (syntax-free-identifier=? tail other-tail))] 48 | [_ #false])] 49 | [(cons head tail) 50 | (match other-pair 51 | [(cons other-head other-tail) 52 | (and (syntax-free-identifier=? head other-head) 53 | (syntax-pair-free-identifier=? tail other-tail))] 54 | [_ #false])])) 55 | 56 | 57 | (module+ test 58 | (test-case "syntax-free-identifier=?" 59 | (check-true (syntax-free-identifier=? #'5 #'5)) 60 | (check-false (syntax-free-identifier=? #'5 #'7)) 61 | (check-false (syntax-free-identifier=? #'5 #'x)) 62 | (check-true (syntax-free-identifier=? #'x #'x)) 63 | (check-true (syntax-free-identifier=? #'(x y z) #'(x y z))) 64 | (check-false (syntax-free-identifier=? #'(x y z) #'(x y))) 65 | (check-true (syntax-free-identifier=? #'(x (y) z) #'(x (y) z))) 66 | (check-false (syntax-free-identifier=? #'(x (y) z) #'(x y z))))) 67 | -------------------------------------------------------------------------------- /default-recommendations/private/syntax-identifier-sets.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [in-syntax-identifiers (-> syntax? (sequence/c identifier?))] 10 | [syntax-identifiers (-> syntax? (set/c identifier? #:cmp 'equal))] 11 | [syntax-free-identifiers (-> syntax? immutable-free-id-set?)] 12 | [syntax-bound-identifiers (-> syntax? immutable-bound-id-set?)])) 13 | 14 | 15 | (require guard 16 | racket/sequence 17 | racket/set 18 | racket/stream 19 | syntax/id-set 20 | syntax/parse) 21 | 22 | 23 | ;@---------------------------------------------------------------------------------------------------- 24 | 25 | 26 | (define (in-syntax-identifiers stx) 27 | (stream* 28 | (syntax-parse stx 29 | #:datum-literals (quote) 30 | [(quote _) (stream)] 31 | [(subform ...) (apply stream-append (map in-syntax-identifiers (attribute subform)))] 32 | [(subform ...+ . tail-form) 33 | (stream-append (apply stream-append (map in-syntax-identifiers (attribute subform))) 34 | (in-syntax-identifiers (attribute tail-form)))] 35 | [id:id (stream (attribute id))] 36 | [_ (stream)]))) 37 | 38 | 39 | (define (syntax-identifiers stx) 40 | (for/set ([id (in-syntax-identifiers stx)]) 41 | id)) 42 | 43 | 44 | (define (syntax-free-identifiers stx) 45 | (immutable-free-id-set (syntax-identifiers stx))) 46 | 47 | 48 | (define (syntax-bound-identifiers stx) 49 | (immutable-bound-id-set (syntax-identifiers stx))) 50 | -------------------------------------------------------------------------------- /default-recommendations/private/syntax-lines.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [oneline-syntax? (-> any/c boolean?)] 10 | [multiline-syntax? (-> any/c boolean?)])) 11 | 12 | 13 | (require rebellion/streaming/reducer 14 | rebellion/streaming/transducer 15 | resyntax/private/syntax-traversal) 16 | 17 | 18 | (module+ test 19 | (require rackunit 20 | rebellion/private/static-name 21 | (submod ".."))) 22 | 23 | 24 | ;@---------------------------------------------------------------------------------------------------- 25 | 26 | 27 | (define (oneline-syntax? v) 28 | (and (syntax? v) (equal? (syntax-line-count v) 1))) 29 | 30 | 31 | (define (multiline-syntax? v) 32 | (and (syntax? v) (> (syntax-line-count v) 1))) 33 | 34 | 35 | (define (syntax-line-count stx) 36 | (transduce (leaves-in-syntax stx) 37 | (mapping syntax-line) 38 | (deduplicating) 39 | #:into into-count)) 40 | 41 | 42 | (module+ test 43 | (test-case (name-string oneline-syntax?) 44 | (check-true (oneline-syntax? #'a)) 45 | (check-true (oneline-syntax? #'(a b c))) 46 | (check-false (oneline-syntax? #'(a 47 | b 48 | c))) 49 | (check-false (oneline-syntax? #'(1 50 | 2 51 | 3)))) 52 | 53 | (test-case (name-string multiline-syntax?) 54 | (check-false (multiline-syntax? #'a)) 55 | (check-false (multiline-syntax? #'(a b c))) 56 | (check-true (multiline-syntax? #'(a 57 | b 58 | c))) 59 | (check-true (multiline-syntax? #'(1 60 | 2 61 | 3))))) 62 | -------------------------------------------------------------------------------- /default-recommendations/private/syntax-tree.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | ;; This module defines a syntax-tree syntax class for recognizing trees of nested expressions. It's 5 | ;; primarily intended for implementing various tree-flattening refactoring rules that rewrite forms 6 | ;; like (or a b (or c d) e) to (or a b c d e). The syntax class accepts an identifier that determines 7 | ;; what subforms count as branches, and it parses out the leaves of the tree. It also makes the rank 8 | ;; of the tree (the number of levels in the tree) available as an attribute, so that the flattening 9 | ;; refactoring rules can avoid flattening trees that are already flat. 10 | 11 | 12 | (provide syntax-tree) 13 | 14 | 15 | (require rebellion/base/option 16 | rebellion/streaming/reducer 17 | rebellion/streaming/transducer 18 | syntax/parse) 19 | 20 | 21 | (module+ test 22 | (require rackunit 23 | (submod ".."))) 24 | 25 | 26 | ;@---------------------------------------------------------------------------------------------------- 27 | 28 | 29 | (define-syntax-class (syntax-tree branch-identifier) 30 | #:attributes ([leaf 1] rank) 31 | #:commit 32 | 33 | (pattern (id:id subtree ...) 34 | #:declare subtree (syntax-tree branch-identifier) 35 | #:when (free-identifier=? #'id branch-identifier) 36 | #:cut 37 | #:with (leaf ...) #'(subtree.leaf ... ...) 38 | #:attr rank (add1 (option-get (transduce (attribute subtree.rank) #:into (into-max)) 0))) 39 | 40 | (pattern other 41 | #:with (leaf ...) #'(other) 42 | #:attr rank 0)) 43 | 44 | 45 | (module+ test 46 | (test-case "expression-tree" 47 | 48 | (define (leaves stx) 49 | (syntax-parse stx 50 | [expr 51 | #:declare expr (syntax-tree #'or) 52 | (syntax->datum #'(expr.leaf ...))])) 53 | 54 | (define (rank stx) 55 | (syntax-parse stx 56 | [expr 57 | #:declare expr (syntax-tree #'or) 58 | (attribute expr.rank)])) 59 | 60 | (test-case "no outer form" 61 | (define stx #'foo) 62 | (check-equal? (leaves stx) '(foo)) 63 | (check-equal? (rank stx) 0)) 64 | 65 | (test-case "unrelated outer form" 66 | (define stx #'(foo a b c)) 67 | (check-equal? (leaves stx) '((foo a b c))) 68 | (check-equal? (rank stx) 0)) 69 | 70 | (test-case "empty outer form" 71 | (define stx #'(or)) 72 | (check-equal? (leaves stx) '()) 73 | (check-equal? (rank stx) 1)) 74 | 75 | (test-case "flat outer form" 76 | (define stx #'(or a b c)) 77 | (check-equal? (leaves stx) '(a b c)) 78 | (check-equal? (rank stx) 1)) 79 | 80 | (test-case "empty subform in empty outer form" 81 | (define stx #'(or (or))) 82 | (check-equal? (leaves stx) '()) 83 | (check-equal? (rank stx) 2)) 84 | 85 | (test-case "empty subform" 86 | (define stx #'(or a (or) b)) 87 | (check-equal? (leaves stx) '(a b)) 88 | (check-equal? (rank stx) 2)) 89 | 90 | (test-case "two singleton subforms" 91 | (define stx #'(or (or a) (or b))) 92 | (check-equal? (leaves stx) '(a b)) 93 | (check-equal? (rank stx) 2)) 94 | 95 | (test-case "two subforms" 96 | (define stx #'(or (or a b c) (or a b c))) 97 | (check-equal? (leaves stx) '(a b c a b c)) 98 | (check-equal? (rank stx) 2)) 99 | 100 | (test-case "deeply nested subforms" 101 | (define stx #'(or a (or b (or c (or d))))) 102 | (check-equal? (leaves stx) '(a b c d)) 103 | (check-equal? (rank stx) 4)))) 104 | -------------------------------------------------------------------------------- /default-recommendations/require-and-provide-suggestions-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations require-and-provide-suggestions-all-enabled-for-test 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "duplicate provided identifiers should be removed" 12 | ---------------------------------------- 13 | (provide foo 14 | foo 15 | foo) 16 | (define foo 1) 17 | ---------------------------------------- 18 | ---------------------------------------- 19 | (provide foo) 20 | (define foo 1) 21 | ---------------------------------------- 22 | 23 | 24 | test: "removing duplicate provided identifiers leaves other exports unchanged" 25 | ---------------------------------------- 26 | (provide a 27 | foo 28 | b 29 | foo 30 | c) 31 | (define a 1) 32 | (define b 1) 33 | (define c 1) 34 | (define foo 1) 35 | ---------------------------------------- 36 | ---------------------------------------- 37 | (provide a 38 | foo 39 | b 40 | c) 41 | (define a 1) 42 | (define b 1) 43 | (define c 1) 44 | (define foo 1) 45 | ---------------------------------------- 46 | 47 | 48 | test: "provide deduplication doesn't affect exports at different phases" 49 | ---------------------------------------- 50 | (provide foo 51 | (for-syntax foo)) 52 | (require (for-syntax racket/base)) 53 | (define foo 1) 54 | (begin-for-syntax 55 | (define foo 2)) 56 | ---------------------------------------- 57 | 58 | 59 | test: "require tidying sorts collection paths by name" 60 | ---------------------------------------- 61 | (require racket/string 62 | racket/hash 63 | racket/list) 64 | ---------------------------------------- 65 | ---------------------------------------- 66 | (require racket/hash 67 | racket/list 68 | racket/string) 69 | ---------------------------------------- 70 | 71 | 72 | 73 | test: "require tidying does nothing when collection paths already sorted by name" 74 | ---------------------------------------- 75 | (require racket/hash 76 | racket/list 77 | racket/string) 78 | ---------------------------------------- 79 | 80 | 81 | test: "require tidying removes duplicate imports" 82 | ---------------------------------------- 83 | (require racket/list 84 | racket/list) 85 | ---------------------------------------- 86 | - (require racket/list) 87 | 88 | 89 | test: "require tidying sorts for-syntax before plain" 90 | ---------------------------------------- 91 | (require racket/list 92 | (for-syntax racket/string)) 93 | ---------------------------------------- 94 | ---------------------------------------- 95 | (require (for-syntax racket/string) 96 | racket/list) 97 | ---------------------------------------- 98 | 99 | 100 | test: "require tidying should move non-phase spec forms after collections" 101 | ---------------------------------------- 102 | (require (only-in racket/list first) 103 | (only-in racket/list second) 104 | (prefix-in s: racket/string) 105 | racket/hash) 106 | ---------------------------------------- 107 | ---------------------------------------- 108 | (require racket/hash 109 | (only-in racket/list first) 110 | (only-in racket/list second) 111 | (prefix-in s: racket/string)) 112 | ---------------------------------------- 113 | 114 | 115 | test: "require tidying should move non-phase spec forms before relative paths" 116 | ---------------------------------------- 117 | (require "require-and-provide-suggestions.rkt" 118 | (only-in racket/list first) 119 | (only-in racket/list second) 120 | (prefix-in s: racket/string)) 121 | ---------------------------------------- 122 | ---------------------------------------- 123 | (require (only-in racket/list first) 124 | (only-in racket/list second) 125 | (prefix-in s: racket/string) 126 | "require-and-provide-suggestions.rkt") 127 | ---------------------------------------- 128 | 129 | 130 | test: "require tidying of only non-phase spec forms should do nothing" 131 | ---------------------------------------- 132 | (require (only-in racket/list first) 133 | (only-in racket/hash hash-union)) 134 | ---------------------------------------- 135 | 136 | 137 | test: "require tidying shouldn't trigger when transformers are imported and used" 138 | ---------------------------------------- 139 | (require racket/require 140 | (multi-in racket (list set dict)) 141 | racket/hash) 142 | ---------------------------------------- 143 | 144 | 145 | test: "require tidying shouldn't trigger when transformers are imported and used in nested specs" 146 | ---------------------------------------- 147 | (require racket/require 148 | (prefix-in racket: (multi-in racket (list set dict))) 149 | racket/hash) 150 | ---------------------------------------- 151 | -------------------------------------------------------------------------------- /default-recommendations/string-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations string-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (require racket/string) 11 | ------------------------------ 12 | 13 | 14 | test: "display newline refactorable to newline" 15 | - (display "\n") 16 | - (displayln "") 17 | - (newline) 18 | 19 | 20 | test: "display followed by newline refactorable to displayln" 21 | ------------------------------ 22 | (define (foo) 23 | (display 42) 24 | (newline)) 25 | ------------------------------ 26 | ------------------------------ 27 | (define (foo) 28 | (displayln 42)) 29 | ------------------------------ 30 | 31 | 32 | test: "string-append before string-join refactorable to string-join with #:before-first" 33 | - (string-append "The " (string-join (list "fox" "hen" "dog"))) 34 | - (string-join (list "fox" "hen" "dog") #:before-first "The ") 35 | 36 | 37 | test: "string-append after string-join refactorable to string-join with #:after-last" 38 | - (string-append (string-join (list "fox" "hen" "dog")) " jumped") 39 | - (string-join (list "fox" "hen" "dog") #:after-last " jumped") 40 | 41 | 42 | test: "string-append around string-join refactorable to string-join with keyword arguments" 43 | - (string-append "The " (string-join (list "fox" "hen" "dog")) " jumped") 44 | - (string-join (list "fox" "hen" "dog") #:before-first "The " #:after-last " jumped") 45 | 46 | 47 | test: "string-append before string-join with sep refactorable to string-join with #:before-first" 48 | - (string-append "The " (string-join (list "fox" "hen" "dog") ", ")) 49 | - (string-join (list "fox" "hen" "dog") ", " #:before-first "The ") 50 | 51 | 52 | test: 53 | "multiline string-append around string-join refactorable to multiline string-join with keyword\ 54 | arguments" 55 | ------------------------------ 56 | (string-append 57 | "The " 58 | (string-join (list "fox" "hen" "dog" "cat" "horse")) 59 | " all jumped together") 60 | ------------------------------ 61 | ------------------------------ 62 | (string-join (list "fox" "hen" "dog" "cat" "horse") 63 | #:before-first "The " 64 | #:after-last " all jumped together") 65 | ------------------------------ 66 | 67 | 68 | test: "string-append with only one string can be removed" 69 | - (string-append "hello") 70 | - "hello" 71 | 72 | 73 | test: "manual string-join can be replaced with real string-join" 74 | ------------------------------ 75 | (require racket/list) 76 | (apply string-append (add-between (list "apple" "orange" "banana") ", ")) 77 | ------------------------------ 78 | ------------------------------ 79 | (require racket/list) 80 | (string-join (list "apple" "orange" "banana") ", ") 81 | ------------------------------ 82 | 83 | 84 | test: "format with only one argument can be removed" 85 | - (format "hello") 86 | - "hello" 87 | 88 | 89 | test: "format with only one argument can't be removed when formatting directives are present" 90 | - (format "hello ~a") 91 | -------------------------------------------------------------------------------- /default-recommendations/string-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [string-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require racket/list 13 | racket/set 14 | racket/string 15 | rebellion/private/static-name 16 | resyntax/base 17 | resyntax/private/syntax-neighbors 18 | syntax/parse) 19 | 20 | 21 | ;@---------------------------------------------------------------------------------------------------- 22 | 23 | 24 | (define-refactoring-rule display-newline-to-newline 25 | #:description "The `newline` function can be used to print a single newline character." 26 | #:literals (display displayln) 27 | (~or (display "\n") (displayln "")) 28 | (newline)) 29 | 30 | 31 | (define-syntax-class newline-by-any-name 32 | #:literals (display displayln newline) 33 | (pattern (~or (display "\n") (displayln "") (newline)))) 34 | 35 | 36 | (define-splicing-syntax-class body-forms-not-starting-with-newline 37 | (pattern (~seq)) 38 | (pattern (~seq (~not :newline-by-any-name) body ...))) 39 | 40 | 41 | (define-definition-context-refactoring-rule display-and-newline-to-displayln 42 | #:description "The `displayln` function can be used to display a value with a newline after it." 43 | #:literals (display) 44 | (~seq before ... 45 | (~and display-form (display v)) 46 | newline-after:newline-by-any-name 47 | after:body-forms-not-starting-with-newline) 48 | (before ... 49 | (~replacement (displayln v) #:original-splice (display-form newline-after)) 50 | (~@ . after))) 51 | 52 | 53 | (define-splicing-syntax-class keywordless-string-join-call 54 | #:literals (string-join) 55 | (pattern (~seq string-join strs (~optional sep)))) 56 | 57 | 58 | (define-syntax-class string-append-and-string-join-expression 59 | #:attributes (refactored) 60 | #:literals (string-append) 61 | 62 | (pattern (string-append before (join-call:keywordless-string-join-call)) 63 | #:with refactored #'((~@ . join-call) #:before-first before)) 64 | 65 | (pattern (string-append (join-call:keywordless-string-join-call) after) 66 | #:with refactored #'((~@ . join-call) #:after-last after)) 67 | 68 | (pattern (string-append before (join-call:keywordless-string-join-call) after) 69 | #:with refactored #'((~@ . join-call) #:before-first before #:after-last after))) 70 | 71 | 72 | (define-refactoring-rule string-append-and-string-join-to-string-join 73 | #:description 74 | "This use of `string-append` can be removed by using `string-join`'s keyword arguments." 75 | #:literals (string-join) 76 | expr:string-append-and-string-join-expression 77 | expr.refactored) 78 | 79 | 80 | (define-refactoring-rule string-append-identity 81 | #:description "This use of `string-append` does nothing." 82 | #:literals (string-append) 83 | (string-append s) 84 | s) 85 | 86 | 87 | (define-refactoring-rule manual-string-join 88 | #:description "This use of `string-append` and `add-between` is equivalent to `string-join`." 89 | #:literals (apply string-append add-between) 90 | (apply string-append (add-between strings separator)) 91 | (string-join strings separator)) 92 | 93 | 94 | (define formatting-directives 95 | (set "~n" 96 | "~%" 97 | "~a" 98 | "~A" 99 | "~s" 100 | "~S" 101 | "~.a" 102 | "~.A" 103 | "~.s" 104 | "~.S" 105 | "~.v" 106 | "~.V" 107 | "~e" 108 | "~E" 109 | "~c" 110 | "~C" 111 | "~b" 112 | "~B" 113 | "~o" 114 | "~O" 115 | "~x" 116 | "~X" 117 | "~~" 118 | "~ " 119 | "~\n" 120 | "~\t")) 121 | 122 | 123 | (define (string-contains-formatting-directives? s) 124 | (for/or ([directive (in-set formatting-directives)]) 125 | (string-contains? s directive))) 126 | 127 | 128 | (define-refactoring-rule format-identity 129 | #:description "This use of `format` does nothing." 130 | #:literals (format) 131 | (format s:str) 132 | #:when (not (string-contains-formatting-directives? (syntax-e #'s))) 133 | s) 134 | 135 | 136 | (define-refactoring-suite string-shortcuts 137 | #:rules (display-and-newline-to-displayln 138 | display-newline-to-newline 139 | format-identity 140 | manual-string-join 141 | string-append-and-string-join-to-string-join 142 | string-append-identity)) 143 | -------------------------------------------------------------------------------- /default-recommendations/syntax-parse-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations syntax-parse-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------ 9 | #lang racket/base 10 | (require syntax/parse/define) 11 | ------------------------------ 12 | 13 | 14 | test: "define-simple-macro refactorable to define-syntax-parse-rule" 15 | ------------------------------ 16 | (define-simple-macro (my-or a:expr b:expr) 17 | (let ([tmp a]) (if a a b))) 18 | ------------------------------ 19 | ------------------------------ 20 | (define-syntax-parse-rule (my-or a:expr b:expr) 21 | (let ([tmp a]) (if a a b))) 22 | ------------------------------ 23 | 24 | 25 | test: "define-simple-macro with body comments refactorable to define-syntax-parse-rule" 26 | ------------------------------ 27 | (define-simple-macro (my-or a:expr b:expr) 28 | ;; The let form is needed to avoid evaluating a twice. 29 | (let ([tmp a]) (if a a b))) 30 | ------------------------------ 31 | ------------------------------ 32 | (define-syntax-parse-rule (my-or a:expr b:expr) 33 | ;; The let form is needed to avoid evaluating a twice. 34 | (let ([tmp a]) (if a a b))) 35 | ------------------------------ 36 | 37 | 38 | test: "define-syntax-parse-rule not refactorable (https://github.com/jackfirth/resyntax/issues/106)" 39 | ------------------------------ 40 | (define-syntax-parse-rule (my-or a:expr b:expr) 41 | ;; The let form is needed to avoid evaluating a twice. 42 | (let ([tmp a]) (if a a b))) 43 | ------------------------------ 44 | 45 | 46 | test: "migrating define-simple-macro doesn't reformat the entire macro definition" 47 | ------------------------------ 48 | (define-simple-macro (my-or a:expr b:expr) 49 | ( let ([tmp a] ) 50 | (if a a b))) 51 | ------------------------------ 52 | ------------------------------ 53 | (define-syntax-parse-rule (my-or a:expr b:expr) 54 | ( let ([tmp a] ) 55 | (if a a b))) 56 | ------------------------------ 57 | 58 | 59 | test: "migrating define-simple-macro does reformat when the header is long" 60 | ------------------------------ 61 | (define-simple-macro (my-or a:expr b:expr fooooooooooooooooooooooooooooooooooooooooooooooooooooooo) 62 | ( let ([tmp a] ) 63 | (if a a b))) 64 | ------------------------------ 65 | ------------------------------ 66 | (define-syntax-parse-rule (my-or a:expr 67 | b:expr 68 | fooooooooooooooooooooooooooooooooooooooooooooooooooooooo) 69 | (let ([tmp a]) (if a a b))) 70 | ------------------------------ 71 | 72 | 73 | test: "migrating define-simple-macro does reformat when the header is multiple lines" 74 | ------------------------------ 75 | (define-simple-macro (my-or 76 | a:expr b:expr) 77 | ( let ([tmp a] ) 78 | (if a a b))) 79 | ------------------------------ 80 | ------------------------------ 81 | (define-syntax-parse-rule (my-or a:expr b:expr) 82 | (let ([tmp a]) (if a a b))) 83 | ------------------------------ 84 | 85 | 86 | test: "migrating define-simple-macro does reformat when the header is on the next line" 87 | ------------------------------ 88 | (define-simple-macro 89 | (my-or 90 | a:expr b:expr) 91 | ( let ([tmp a] ) 92 | (if a a b))) 93 | ------------------------------ 94 | ------------------------------ 95 | (define-syntax-parse-rule (my-or a:expr b:expr) 96 | (let ([tmp a]) (if a a b))) 97 | ------------------------------ 98 | -------------------------------------------------------------------------------- /default-recommendations/syntax-parse-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [syntax-parse-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require resyntax/base 13 | resyntax/default-recommendations/private/syntax-lines 14 | syntax/parse/define) 15 | 16 | 17 | ;@---------------------------------------------------------------------------------------------------- 18 | 19 | 20 | (define define-simple-macro-migration-name-length-increase 21 | (- (string-length "define-syntax-parse-rule") (string-length "define-simple-macro"))) 22 | 23 | (define-refactoring-rule define-simple-macro-to-define-syntax-parse-rule 24 | #:description "The `define-simple-macro` form has been renamed to `define-syntax-parse-rule`." 25 | #:literals (define-simple-macro) 26 | (original:define-simple-macro header form ...) 27 | 28 | ;; The define-simple-macro is a renamed alias of define-syntax-parse-rule, so it's 29 | ;; free-identifier=?. As a result, we need to check the actual symbol of the identifier instead of 30 | ;; just its binding. See https://github.com/jackfirth/resyntax/issues/106. 31 | #:when (equal? (syntax-e #'original) 'define-simple-macro) 32 | 33 | #:do 34 | [(define should-reformat? 35 | (or (multiline-syntax? #'header) 36 | (not (equal? (syntax-line #'original) (syntax-line #'header))) 37 | (> (+ (syntax-column #'header) 38 | (syntax-span #'header) 39 | define-simple-macro-migration-name-length-increase) 40 | 102)))] 41 | 42 | #:with new-id (if should-reformat? 43 | #'define-syntax-parse-rule 44 | #'(~focus-replacement-on define-syntax-parse-rule)) 45 | 46 | (new-id header form ...)) 47 | 48 | 49 | (define-refactoring-suite syntax-parse-shortcuts 50 | #:rules (define-simple-macro-to-define-syntax-parse-rule)) 51 | -------------------------------------------------------------------------------- /default-recommendations/syntax-rules-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations syntax-rules-shortcuts 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "single-clause syntax-rules macro refactorable to define-syntax-rule" 12 | ------------------------------ 13 | (define-syntax my-or 14 | (syntax-rules () 15 | [(my-or a b) 16 | (let ([tmp a]) (if a a b))])) 17 | ------------------------------ 18 | ------------------------------ 19 | (define-syntax-rule (my-or a b) 20 | (let ([tmp a]) (if a a b))) 21 | ------------------------------ 22 | 23 | 24 | test: "single-clause syntax-rules macro not referring to name refactorable to define-syntax-rule" 25 | ------------------------------ 26 | (define-syntax my-or 27 | (syntax-rules () 28 | [(_ a b) 29 | (let ([tmp a]) (if a a b))])) 30 | ------------------------------ 31 | ------------------------------ 32 | (define-syntax-rule (my-or a b) 33 | (let ([tmp a]) (if a a b))) 34 | ------------------------------ 35 | -------------------------------------------------------------------------------- /default-recommendations/syntax-rules-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [syntax-rules-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require rebellion/private/static-name 13 | resyntax/base 14 | resyntax/private/syntax-replacement 15 | syntax/parse) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-refactoring-rule define-syntax-syntax-rules-to-define-syntax-rule 22 | #:description 23 | "This `define-syntax` macro can be replaced with a simpler, equivalent `define-syntax-rule` macro." 24 | #:literals (define-syntax syntax-rules) 25 | (define-syntax macro:id (syntax-rules () [(_ . pattern) template])) 26 | (define-syntax-rule (macro . pattern) template)) 27 | 28 | 29 | (define-refactoring-suite syntax-rules-shortcuts 30 | #:rules (define-syntax-syntax-rules-to-define-syntax-rule)) 31 | -------------------------------------------------------------------------------- /default-recommendations/syntax-shortcuts-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations syntax-shortcuts 5 | 6 | 7 | header: 8 | ------------------------------------------------------------------------------------------------------ 9 | #lang racket/base 10 | (require racket/syntax) 11 | ------------------------------------------------------------------------------------------------------ 12 | 13 | 14 | test: "syntax-e on a lone format-id argument is removable" 15 | - (format-id #'foo "~a/c" (syntax-e #'bar)) 16 | - (format-id #'foo "~a/c" #'bar) 17 | 18 | 19 | test: "syntax-e on multiple format-id arguments is removable" 20 | - (format-id #'foo "~a.~a.~a" (syntax-e #'bar) (syntax-e #'baz) (syntax-e #'blah)) 21 | - (format-id #'foo "~a.~a.~a" #'bar #'baz #'blah) 22 | 23 | 24 | test: "syntax-e on a single format-id argument is removable" 25 | - (format-id #'foo "~a.~a.~a" #'bar (syntax-e #'baz) #'blah) 26 | - (format-id #'foo "~a.~a.~a" #'bar #'baz #'blah) 27 | 28 | 29 | test: "format-id call without any syntax-e unwrapped arguments not refactorable" 30 | - (format-id #'foo "~a.~a.~a" #'bar #'baz #'blah) 31 | 32 | 33 | test: "making a symbol with format can be simplified to format-symbol" 34 | - (string->symbol (format "make-~a" "foo")) 35 | - (format-symbol "make-~a" "foo") 36 | 37 | 38 | test: "making a symbol with format from a symbol can be simplified to format-symbol" 39 | - (string->symbol (format "make-~a" (symbol->string 'foo))) 40 | - (format-symbol "make-~a" 'foo) 41 | 42 | 43 | test: "making a symbol with format from an identifier can be simplified to format-symbol" 44 | - (string->symbol (format "make-~a" (symbol->string (syntax-e #'foo)))) 45 | - (format-symbol "make-~a" #'foo) 46 | 47 | 48 | test: "making a symbol with format from a keyword can be simplified to format-symbol" 49 | - (string->symbol (format "make-~a" (keyword->string '#:foo))) 50 | - (format-symbol "make-~a" '#:foo) 51 | 52 | 53 | test: "making a symbol with format from a keyword syntax object can be simplified to format-symbol" 54 | - (string->symbol (format "make-~a" (keyword->string (syntax-e #'#:foo)))) 55 | - (format-symbol "make-~a" #'#:foo) 56 | -------------------------------------------------------------------------------- /default-recommendations/syntax-shortcuts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [syntax-shortcuts refactoring-suite?])) 10 | 11 | 12 | (require racket/string 13 | racket/syntax 14 | rebellion/private/static-name 15 | resyntax/base 16 | syntax/parse) 17 | 18 | 19 | ;@---------------------------------------------------------------------------------------------------- 20 | 21 | 22 | (define-syntax-class format-id-argument 23 | #:attributes (uses-syntax-e? simplified) 24 | #:literals (syntax-e) 25 | 26 | (pattern (syntax-e simplified:expr) 27 | #:with uses-syntax-e? #'#true) 28 | 29 | (pattern simplified:expr 30 | #:with uses-syntax-e? #'#false)) 31 | 32 | 33 | (define-refactoring-rule syntax-e-in-format-id-unnecessary 34 | #:description 35 | "Using `syntax-e` on the arguments of `format-id` is unnecessary, `format-id` already unwrap 36 | syntax object arguments." 37 | #:literals (format-id syntax-e) 38 | 39 | (format-id lctx:expr fmt:expr arg:format-id-argument ...+) 40 | #:when 41 | (for/or ([uses-syntax-e? (attribute arg.uses-syntax-e?)]) 42 | (syntax-e uses-syntax-e?)) 43 | 44 | (format-id lctx fmt arg.simplified ...)) 45 | 46 | 47 | (define-syntax-class format-symbol-argument 48 | #:attributes (simplified) 49 | #:literals (syntax-e keyword->string symbol->string) 50 | 51 | (pattern (syntax-e inner:format-symbol-argument) #:attr simplified (attribute inner.simplified)) 52 | 53 | (pattern (keyword->string inner:format-symbol-argument) 54 | #:attr simplified (attribute inner.simplified)) 55 | 56 | (pattern (symbol->string inner:format-symbol-argument) 57 | #:attr simplified (attribute inner.simplified)) 58 | 59 | (pattern simplified:expr)) 60 | 61 | 62 | ;; The format-symbol function only allows ~a placeholders. Rather a fancy generic utilty that finds 63 | ;; all placeholders, we just explicitly list out all the other ones and check one-by-one whether any 64 | ;; of them are contained in the template string. That's easier to implement and the performance 65 | ;; doesn't matter at all since template strings are almost always short. 66 | (define disallowed-format-symbol-placeholders 67 | (list "~n" 68 | "~%" 69 | "~s" 70 | "~S" 71 | "~v" 72 | "~V" 73 | "~.a" 74 | "~.A" 75 | "~.s" 76 | "~.S" 77 | "~.v" 78 | "~.V" 79 | "~e" 80 | "~E" 81 | "~c" 82 | "~C" 83 | "~b" 84 | "~B" 85 | "~o" 86 | "~O" 87 | "~x" 88 | "~X" 89 | "~ " 90 | "~\n" 91 | "~\t")) 92 | 93 | 94 | (define-refactoring-rule format-string-to-format-symbol 95 | #:description 96 | "This `format` expression can be simplified to an equivalent `format-symbol` expression." 97 | #:literals (format string->symbol) 98 | 99 | (string->symbol (format template:str arg:format-symbol-argument ...)) 100 | #:when (for/and ([disallowed (in-list disallowed-format-symbol-placeholders)]) 101 | (not (string-contains? (syntax-e #'template) disallowed))) 102 | 103 | (format-symbol template (~replacement arg.simplified #:original arg) ...)) 104 | 105 | 106 | (define-refactoring-suite syntax-shortcuts 107 | #:rules (format-string-to-format-symbol 108 | syntax-e-in-format-id-unnecessary)) 109 | -------------------------------------------------------------------------------- /default-recommendations/unused-binding-suggestions-test.rkt: -------------------------------------------------------------------------------- 1 | #lang resyntax/test 2 | 3 | 4 | require: resyntax/default-recommendations unused-binding-suggestions 5 | 6 | 7 | header: 8 | - #lang racket/base 9 | 10 | 11 | test: "should remove unused function definitions from internal definition contexts" 12 | ------------------------------ 13 | (define (foo) 14 | (define (bar) 15 | (displayln "bar")) 16 | 42) 17 | ------------------------------ 18 | ------------------------------ 19 | (define (foo) 20 | 42) 21 | ------------------------------ 22 | 23 | 24 | test: "should not remove used function definitions from internal definition contexts" 25 | ------------------------------ 26 | (define (foo) 27 | (define (bar) 28 | (displayln "bar")) 29 | (bar) 30 | 42) 31 | ------------------------------ 32 | 33 | 34 | test: "removing unused function definitions shouldn't reformat entire context" 35 | ------------------------------ 36 | (define (foo) 37 | ( displayln "foo" ) 38 | 39 | 40 | (define (bar) 41 | (displayln "bar")) 42 | 43 | (define x 2) 44 | ( * x 2 )) 45 | ------------------------------ 46 | ------------------------------ 47 | (define (foo) 48 | ( displayln "foo" ) 49 | 50 | 51 | (define x 2) 52 | ( * x 2 )) 53 | ------------------------------ 54 | 55 | 56 | test: "should remove unused side-effect-free variable definitions from internal definition contexts" 57 | ------------------------------ 58 | (define (foo) 59 | (define bar "bar") 60 | 42) 61 | ------------------------------ 62 | ------------------------------ 63 | (define (foo) 64 | 42) 65 | ------------------------------ 66 | -------------------------------------------------------------------------------- /default-recommendations/unused-binding-suggestions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [unused-binding-suggestions refactoring-suite?])) 10 | 11 | 12 | (require racket/list 13 | resyntax/base 14 | resyntax/default-recommendations/private/pure-expression 15 | syntax/parse) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define-syntax-class side-effect-free-definition 22 | #:attributes (id) 23 | #:literals (define) 24 | (pattern (define (id:id . _) . _)) 25 | (pattern (define id:id :pure-expression))) 26 | 27 | 28 | (define-definition-context-refactoring-rule unused-definition 29 | #:description "This definition is not used." 30 | (~seq before ... definition:side-effect-free-definition first-after remaining-after ...) 31 | #:when (empty? (or (syntax-property (attribute definition.id) 'identifier-usages) '())) 32 | (before ... 33 | (~focus-replacement-on (~replacement first-after #:original-splice (definition first-after))) 34 | remaining-after ...)) 35 | 36 | 37 | (define-refactoring-suite unused-binding-suggestions 38 | #:rules (unused-definition)) 39 | -------------------------------------------------------------------------------- /default-recommendations/windows-newline-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require rackunit 6 | resyntax/default-recommendations 7 | resyntax/test/private/rackunit)) 8 | 9 | 10 | ;@---------------------------------------------------------------------------------------------------- 11 | 12 | 13 | (module+ test 14 | (test-case "windows-style newlines should be replaced with regular newlines" 15 | (parameterize ([current-suite-under-test default-recommendations]) 16 | (define program 17 | (code-block 18 | (string-append "#lang racket/base\r\n" 19 | "(define (foo)\r\n" 20 | " (let ([x 42])\r\n" 21 | " (* x 2)))\r\n"))) 22 | (define expected-program 23 | (code-block 24 | (string-append "#lang racket/base\n" 25 | "(define (foo)\n" 26 | " (define x 42)\n" 27 | " (* x 2))\n"))) 28 | (check-suite-refactors program expected-program)))) 29 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | 4 | (define collection "resyntax") 5 | 6 | 7 | (define scribblings 8 | (list (list "main.scrbl" 9 | (list 'multi-page) 10 | (list 'library) 11 | "resyntax"))) 12 | 13 | 14 | (define deps 15 | (list "compatibility-lib" 16 | "base" 17 | "br-parser-tools-lib" 18 | "brag-lib" 19 | "fancy-app" 20 | "fmt" 21 | "guard" 22 | "rackunit-lib" 23 | "rebellion")) 24 | 25 | 26 | (define build-deps 27 | (list "racket-doc" 28 | "rackunit-lib" 29 | "scribble-lib")) 30 | 31 | 32 | (define racket-launcher-names 33 | (list "resyntax")) 34 | 35 | 36 | (define racket-launcher-libraries 37 | (list "cli.rkt")) 38 | -------------------------------------------------------------------------------- /private/code-snippet.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [code-snippet? (-> any/c boolean?)] 10 | [code-snippet 11 | (-> string? exact-nonnegative-integer? exact-positive-integer? code-snippet?)] 12 | [code-snippet-raw-text (-> code-snippet? immutable-string?)] 13 | [code-snippet-start-column (-> code-snippet? exact-nonnegative-integer?)] 14 | [code-snippet-start-line (-> code-snippet? exact-positive-integer?)] 15 | [code-snippet-end-line (-> code-snippet? exact-positive-integer?)])) 16 | 17 | 18 | (require racket/format 19 | racket/math 20 | racket/sequence 21 | racket/string 22 | rebellion/base/immutable-string) 23 | 24 | 25 | (module+ test 26 | (require rackunit 27 | rebellion/private/static-name 28 | (submod ".."))) 29 | 30 | 31 | ;@---------------------------------------------------------------------------------------------------- 32 | 33 | 34 | (struct code-snippet (raw-text start-column start-line) 35 | #:transparent 36 | 37 | #:guard 38 | (λ (raw-text start-column start-line _) 39 | (values (string->immutable-string raw-text) start-column start-line)) 40 | 41 | #:methods gen:custom-write 42 | [(define (write-proc this out mode) 43 | (define end-line (code-snippet-end-line this)) 44 | (for ([line (in-lines (open-input-string (code-snippet-raw-text this)))] 45 | [n (in-naturals)]) 46 | (define line-number-string 47 | (~a (+ n (code-snippet-start-line this)) #:min-width (digit-count end-line))) 48 | (write-string line-number-string out) 49 | (write-string " " out) 50 | (cond 51 | [(zero? n) (write-string line out)] 52 | [else 53 | (define leading-indentation (make-string (code-snippet-start-column this) #\space)) 54 | (write-string (string-replace line leading-indentation "" #:all? #false) out)]) 55 | (newline out)))]) 56 | 57 | ; code-snippet-start-line and code-snippet-end-line give an inclusive-exclusive range; that is, 58 | ; a one-line snippet on line 10 would have start and end lines of 10 and 11, respectively. 59 | (define (code-snippet-end-line snippet) 60 | (define line-count (sequence-length (in-lines (open-input-string (code-snippet-raw-text snippet))))) 61 | (+ (code-snippet-start-line snippet) line-count)) 62 | 63 | 64 | (module+ test 65 | (test-case (name-string code-snippet-end-line) 66 | (test-case "end-line is one greater than the number of the last line in the snippet" 67 | (define snippet (code-snippet "(+\n 1\n 2\n 3)" 0 6)) 68 | (check-equal? (code-snippet-end-line snippet) 10))) 69 | 70 | (test-case (name-string code-snippet) 71 | (test-case "one-line snippet" 72 | (define snippet (code-snippet "(+ 1 2 3)" 0 1)) 73 | (check-equal? (~a snippet) "1 (+ 1 2 3)\n")) 74 | 75 | (test-case "multiline snippet" 76 | (define snippet (code-snippet "(define (f x)\n (+ x x))" 0 1)) 77 | (check-equal? (~a snippet) "1 (define (f x)\n2 (+ x x))\n")) 78 | 79 | (test-case "indented snippet" 80 | (define snippet (code-snippet "(+ 1 2 3)" 10 1)) 81 | (check-equal? (~a snippet) "1 (+ 1 2 3)\n")) 82 | 83 | (test-case "indented multiline snippet" 84 | (define snippet (code-snippet "(define (f x)\n (+ x x))" 10 1)) 85 | (check-equal? (~a snippet) "1 (define (f x)\n2 (+ x x))\n")) 86 | 87 | (test-case "snippet with line numbers of different digit counts" 88 | (define snippet (code-snippet "(+ 1 2 3)\n(+ 4 5 6)" 0 99)) 89 | (check-equal? (~a snippet) "99 (+ 1 2 3)\n100 (+ 4 5 6)\n")))) 90 | 91 | 92 | (define (digit-count n) 93 | (add1 (exact-floor (log n 10)))) 94 | 95 | 96 | (module+ test 97 | (test-case (name-string digit-count) 98 | (check-equal? (digit-count 1) 1) 99 | (check-equal? (digit-count 123) 3) 100 | (check-equal? (digit-count 10000) 5) 101 | (check-equal? (digit-count 10001) 5) 102 | (check-equal? (digit-count 9999) 4))) 103 | -------------------------------------------------------------------------------- /private/comment-reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [read-comment-locations (->* () (input-port?) range-set?)])) 10 | 11 | 12 | (require br-parser-tools/lex 13 | racket/sequence 14 | rebellion/base/comparator 15 | rebellion/base/range 16 | rebellion/collection/list 17 | rebellion/collection/range-set 18 | rebellion/streaming/reducer 19 | rebellion/streaming/transducer 20 | resyntax/private/syntax-traversal 21 | (prefix-in : br-parser-tools/lex-sre)) 22 | 23 | 24 | (module+ test 25 | (require rackunit 26 | (submod ".."))) 27 | 28 | 29 | ;@---------------------------------------------------------------------------------------------------- 30 | 31 | 32 | (struct comment-set (comment-list) 33 | #:transparent 34 | #:guard (λ (comments _) (sequence->list comments)) 35 | #:property prop:sequence (λ (this) (comment-set-comment-list this))) 36 | 37 | 38 | (define into-comment-set (reducer-map into-list #:range comment-set)) 39 | 40 | 41 | (struct comment (text location) 42 | #:transparent 43 | #:guard (λ (text location _) (values (string->immutable-string text) location))) 44 | 45 | 46 | (define (comment-range comment) 47 | (define loc (comment-location comment)) 48 | (define start (srcloc-position loc)) 49 | (define end (+ start (srcloc-span loc))) 50 | (closed-open-range start end #:comparator natural<=>)) 51 | 52 | 53 | (define (comment-subset comments position-range) 54 | (transduce comments 55 | (filtering (λ (c) (range-encloses? position-range (comment-range c)))) 56 | #:into into-comment-set)) 57 | 58 | 59 | (define (syntax-source-range stx) 60 | (define start (syntax-position stx)) 61 | (define end (+ start (syntax-span stx))) 62 | (closed-open-range start end #:comparator natural<=>)) 63 | 64 | 65 | (define (syntax-original-locations stx) 66 | (transduce (leaves-in-syntax stx syntax-original?) 67 | (mapping syntax-source-range) 68 | #:into into-list)) 69 | 70 | 71 | (define (read-comment-locations [in (current-input-port)]) 72 | (port-count-lines! in) 73 | (define (next!) 74 | (comment-lexer in)) 75 | (transduce (in-producer next! eof) 76 | (mapping srcloc-token-srcloc) 77 | (mapping srcloc-range) 78 | #:into (into-range-set natural<=>))) 79 | 80 | 81 | (define (srcloc-range srcloc) 82 | (define start (sub1 (srcloc-position srcloc))) 83 | (define end (+ start (srcloc-span srcloc))) 84 | (closed-open-range start end #:comparator natural<=>)) 85 | 86 | 87 | (define-tokens racket-tokens (LINE-COMMENT BLOCK-COMMENT)) 88 | 89 | 90 | (define-lex-abbrev racket-line-comment 91 | (concatenation ";" (complement (:: any-string "\n" any-string)) "\n")) 92 | 93 | 94 | (define (build-racket-line-comment lexeme) 95 | (token-LINE-COMMENT (string->immutable-string lexeme))) 96 | 97 | 98 | ;; Technically not correct because block comments can be nested. 99 | (define-lex-abbrev racket-block-comment 100 | (concatenation "#|" (complement (:: any-string (:or "#|" "#|") any-string)) "|#")) 101 | 102 | 103 | (define (build-racket-block-comment lexeme) 104 | (token-BLOCK-COMMENT (string->immutable-string lexeme))) 105 | 106 | 107 | ;; This lexer should also read string literals and discard them, so that comment-starting characters 108 | ;; inside string literals are ignored. 109 | (define comment-lexer 110 | (lexer-srcloc 111 | [racket-line-comment (build-racket-line-comment lexeme)] 112 | [racket-block-comment (build-racket-block-comment lexeme)] 113 | [any-char (return-without-srcloc (comment-lexer input-port))])) 114 | 115 | 116 | (module+ test 117 | (test-case "comment-lexer" 118 | 119 | (define (natural-range start end) 120 | (closed-open-range start end #:comparator natural<=>)) 121 | 122 | (define (read-comments-for-test test-program) 123 | (read-comment-locations (open-input-string test-program 'test-program))) 124 | 125 | (test-case "line comments" 126 | (define input "; This is a comment\n") 127 | (define expected (range-set (natural-range 0 20))) 128 | (check-equal? (read-comments-for-test input) expected)) 129 | 130 | (test-case "double semicolon line comments" 131 | (define input ";; This is a comment\n") 132 | (define expected (range-set (natural-range 0 21))) 133 | (check-equal? (read-comments-for-test input) expected)) 134 | 135 | (test-case "line comments after expressions" 136 | (define input "(void) ; This is a comment\n") 137 | (define expected (range-set (natural-range 7 27))) 138 | (check-equal? (read-comments-for-test input) expected)) 139 | 140 | (test-case "line comments above expressions" 141 | (define input "; This is a comment\n(void)\n") 142 | (define expected (range-set (natural-range 0 20))) 143 | (check-equal? (read-comments-for-test input) expected)) 144 | 145 | (test-case "line comments with non-ASCII characters" 146 | (define input "; λλλλλ\n") 147 | (define expected (range-set (natural-range 0 8))) 148 | (check-equal? (read-comments-for-test input) expected)) 149 | 150 | (test-case "block comments" 151 | (define input "#|\nThis is a block comment\n|#\n") 152 | (define expected (range-set (natural-range 0 29))) 153 | (check-equal? (read-comments-for-test input) expected)) 154 | 155 | (test-case "block comments below expressions" 156 | (define input "(void)\n#|\nThis is a block comment\n|#\n") 157 | (define expected (range-set (natural-range 7 36))) 158 | (check-equal? (read-comments-for-test input) expected)) 159 | 160 | (test-case "block comments above expressions" 161 | (define input "#|\nThis is a block comment\n|#\n(void)\n") 162 | (define expected (range-set (natural-range 0 29))) 163 | (check-equal? (read-comments-for-test input) expected)) 164 | 165 | (test-case "multiple line comments" 166 | (define input "; Line 1\n; Line 2\n; Line 3\n") 167 | (define expected (range-set (natural-range 0 27))) 168 | (check-equal? (read-comments-for-test input) expected)))) 169 | -------------------------------------------------------------------------------- /private/commit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide (struct-out resyntax-commit)) 5 | 6 | 7 | 8 | (struct resyntax-commit (message changes) #:transparent) -------------------------------------------------------------------------------- /private/file-group.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [file-portion? (-> any/c boolean?)] 10 | [file-portion (-> path-string? range-set? file-portion?)] 11 | [file-portion-path (-> file-portion? complete-path?)] 12 | [file-portion-lines (-> file-portion? immutable-range-set?)] 13 | [file-groups-resolve (-> (sequence/c file-group?) (hash/c file-source? immutable-range-set?))] 14 | [file-group? (-> any/c boolean?)] 15 | [single-file-group? (-> any/c boolean?)] 16 | [single-file-group (-> path-string? immutable-range-set? single-file-group?)] 17 | [directory-file-group? (-> any/c boolean?)] 18 | [directory-file-group (-> path-string? directory-file-group?)] 19 | [package-file-group? (-> any/c boolean?)] 20 | [package-file-group (-> string? package-file-group?)] 21 | [git-repository-file-group? (-> any/c boolean?)] 22 | [git-repository-file-group (-> path-string? string? git-repository-file-group?)])) 23 | 24 | 25 | (require fancy-app 26 | guard 27 | pkg/lib 28 | racket/file 29 | racket/match 30 | racket/path 31 | racket/sequence 32 | racket/string 33 | rebellion/base/comparator 34 | rebellion/base/range 35 | rebellion/collection/entry 36 | rebellion/collection/hash 37 | rebellion/collection/list 38 | rebellion/collection/range-set 39 | rebellion/streaming/reducer 40 | rebellion/streaming/transducer 41 | resyntax/private/git 42 | resyntax/private/logger 43 | resyntax/private/source) 44 | 45 | 46 | (module+ test 47 | (require (submod "..") 48 | rackunit)) 49 | 50 | 51 | ;@---------------------------------------------------------------------------------------------------- 52 | 53 | 54 | (struct file-portion (path lines) 55 | #:transparent 56 | #:guard (λ (path lines _) (values (simple-form-path path) lines))) 57 | 58 | 59 | (struct file-group () #:transparent) 60 | 61 | 62 | (struct single-file-group file-group (path ranges) 63 | #:transparent 64 | #:guard (λ (path ranges _) (values (simple-form-path path) ranges))) 65 | 66 | 67 | (struct directory-file-group file-group (path) 68 | #:transparent 69 | #:guard (λ (path _) (simple-form-path path))) 70 | 71 | 72 | (struct package-file-group file-group (package-name) 73 | #:transparent 74 | #:guard (λ (package-name _) (string->immutable-string package-name))) 75 | 76 | 77 | (struct git-repository-file-group file-group (repository-path ref) 78 | #:transparent 79 | #:guard 80 | (λ (repository-path ref _) 81 | (values (simple-form-path repository-path) (string->immutable-string ref)))) 82 | 83 | 84 | (define (file-groups-resolve groups) 85 | (transduce groups 86 | (append-mapping file-group-resolve) 87 | (bisecting (λ (portion) (file-source (file-portion-path portion))) file-portion-lines) 88 | (grouping (make-fold-reducer range-set-add-all (range-set #:comparator natural<=>))) 89 | #:into into-hash)) 90 | 91 | 92 | (define (file-group-resolve group) 93 | (define files 94 | (match group 95 | [(single-file-group path ranges) 96 | (list (file-portion path ranges))] 97 | [(directory-file-group path) 98 | (for/list ([file (in-directory path)]) 99 | (file-portion file (range-set (unbounded-range #:comparator natural<=>))))] 100 | [(package-file-group package-name) 101 | (define pkgdir (pkg-directory package-name)) 102 | (unless pkgdir 103 | (raise-user-error 'resyntax 104 | "cannot analyze package ~a, it hasn't been installed" 105 | package-name)) 106 | (for/list ([file (in-directory (simple-form-path pkgdir))]) 107 | (file-portion file (range-set (unbounded-range #:comparator natural<=>))))] 108 | [(git-repository-file-group repository-path ref) 109 | (parameterize ([current-directory repository-path]) 110 | (define diff-lines (git-diff-modified-lines ref)) 111 | (for/list ([(file lines) (in-hash diff-lines)]) 112 | (log-resyntax-debug "~a: modified lines: ~a" file lines) 113 | (file-portion file (expand-modified-line-set lines))))])) 114 | (transduce files (filtering rkt-file?) #:into into-list)) 115 | 116 | 117 | (define/guard (rkt-file? portion) 118 | (define path (file-portion-path portion)) 119 | (guard (path-has-extension? path #".rkt") #:else #false) 120 | (define content (file->string path)) 121 | (string-prefix? content "#lang racket")) 122 | 123 | 124 | ;; GitHub allows pull request reviews to include comments only on modified lines, plus the 3 lines 125 | ;; before and after any modified lines. 126 | (define (expand-modified-line-set lines) 127 | (define context-lines 128 | (for/list ([line-range (in-range-set lines)]) 129 | (range (range-bound-map (range-lower-bound line-range) (λ (x) (max 0 (- x 3)))) 130 | (range-bound-map (range-upper-bound line-range) (λ (x) (+ x 3))) 131 | #:comparator (range-comparator line-range)))) 132 | (range-set-add-all lines context-lines)) 133 | 134 | 135 | (define (range-bound-map bound f) 136 | (if (unbounded? bound) 137 | unbounded 138 | (range-bound (f (range-bound-endpoint bound)) (range-bound-type bound)))) 139 | 140 | 141 | (module+ test 142 | (test-case "expand-modified-line-set" 143 | (define ranges (range-set (closed-open-range 4 6) (greater-than-range 15))) 144 | (define expected (range-set (closed-open-range 1 9) (greater-than-range 12))) 145 | (check-equal? (expand-modified-line-set ranges) expected))) 146 | -------------------------------------------------------------------------------- /private/git.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [git-diff-modified-lines (-> string? (hash/c path? immutable-range-set?))] 10 | [git-commit! (-> string? void?)])) 11 | 12 | 13 | (require fancy-app 14 | racket/match 15 | racket/port 16 | racket/string 17 | racket/system 18 | rebellion/base/comparator 19 | rebellion/base/option 20 | rebellion/base/range 21 | rebellion/collection/range-set) 22 | 23 | 24 | ;@---------------------------------------------------------------------------------------------------- 25 | 26 | 27 | 28 | (define (git-diff-modified-lines ref) 29 | (define cmd 30 | (format 31 | "git diff -U0 --inter-hunk-context=0 --diff-filter=AM ~a | grep -e '^+++ b/' -e '^@@'" ref)) 32 | (define empty-lines (range-set #:comparator natural<=>)) 33 | (for*/fold ([files (hash)] 34 | [current-file #false] 35 | #:result files) 36 | ([line (in-list (string-split (with-output-to-string (λ () (system cmd))) "\n"))] 37 | [lexeme (in-option (lex-line line))]) 38 | (if (path? lexeme) 39 | (values files lexeme) 40 | (values (hash-update files current-file (range-set-add _ lexeme) empty-lines) 41 | current-file)))) 42 | 43 | 44 | (define (lex-line line) 45 | (define file-match (regexp-match #px"^\\+\\+\\+ b/(.*)$" line)) 46 | (define single-line-match (regexp-match #px"^@@ .* \\+(\\d+) @@" line)) 47 | (define range-match (regexp-match #px"^@@ .* \\+(\\d+),(\\d+) @@" line)) 48 | (cond 49 | [file-match 50 | (match-define (list _ f) file-match) 51 | (present (simplify-path f))] 52 | [single-line-match 53 | (match-define (list _ l) single-line-match) 54 | (let ([l (string->number l)]) 55 | (present (closed-open-range l (add1 l) #:comparator natural<=>)))] 56 | [range-match 57 | (match-define (list _ l s) range-match) 58 | (let ([l (string->number l)] 59 | [s (string->number s)]) 60 | (if (equal? s 0) 61 | absent ;; TODO: fix range-set-add so that I can return an empty range here 62 | (present (closed-open-range l (+ l s) #:comparator natural<=>))))] 63 | [else 64 | (raise-argument-error 65 | 'lex-line 66 | "a git file name line (starting with '+++ b/') or a hunk range line (starting with '@@')" 67 | line)])) 68 | 69 | 70 | (define (git-commit! message) 71 | (define escaped-message (string-replace message "'" "'\"'\"'")) 72 | (unless (system (format "git commit --all --quiet --message='~a'" escaped-message)) 73 | (raise-arguments-error 'git-commit! 74 | "committing files to Git failed" 75 | "commit message" message))) 76 | -------------------------------------------------------------------------------- /private/github.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [github-review-request? (-> any/c boolean?)] 10 | [github-review-request-jsexpr (-> github-review-request? jsexpr?)] 11 | [refactoring-results->github-review 12 | (-> (sequence/c refactoring-result?) #:file-count exact-nonnegative-integer? 13 | github-review-request?)])) 14 | 15 | 16 | (require json 17 | racket/list 18 | racket/match 19 | racket/pretty 20 | racket/sequence 21 | racket/string 22 | rebellion/collection/list 23 | rebellion/streaming/transducer 24 | rebellion/type/record 25 | resyntax/private/line-replacement 26 | resyntax/private/refactoring-result 27 | resyntax/private/run-command 28 | resyntax/private/source 29 | resyntax/private/string-indent 30 | resyntax/private/syntax-replacement) 31 | 32 | 33 | ;@---------------------------------------------------------------------------------------------------- 34 | 35 | 36 | (define-record-type github-review-request 37 | (owner-repo pull-number body event comments)) 38 | 39 | 40 | (define (github-review-request-jsexpr req) 41 | (match-define 42 | (github-review-request 43 | #:owner-repo owner-repo #:pull-number pull-number #:body body #:event event #:comments comments) 44 | req) 45 | (match-define (list owner repo) (string-split owner-repo "/")) 46 | (hash 'owner owner 47 | 'repo repo 48 | 'body body 49 | 'event event 50 | 'comments (map github-review-comment-jsexpr comments) 51 | 'pull_number pull-number)) 52 | 53 | 54 | (define-record-type github-review-comment 55 | (path body start-line end-line start-side end-side)) 56 | 57 | 58 | (define (github-review-comment-jsexpr comment) 59 | (match-define 60 | (github-review-comment #:path path 61 | #:body body 62 | #:start-line start-line 63 | #:end-line end-line 64 | #:start-side start-side 65 | #:end-side end-side) 66 | comment) 67 | (if (= start-line end-line) 68 | (hash 'path path 69 | 'body body 70 | 'line end-line 71 | 'side end-side) 72 | (hash 'path path 73 | 'body body 74 | 'start_line start-line 75 | 'line end-line 76 | 'start_side start-side 77 | 'side end-side))) 78 | 79 | 80 | (define (git-path path) 81 | (string-split (run-command "git" "ls-tree" "-r" "-z" "--name-only" "HEAD" path) "\0")) 82 | 83 | 84 | (define git-pr-ref-regexp #rx"^refs/pull/([0-9]+)/merge$") 85 | 86 | 87 | (define (git-ref->pr-number ref) 88 | (match ref 89 | [(regexp git-pr-ref-regexp (list _ num)) 90 | (string->number num)] 91 | [_ 92 | (error (format "ref ~a doesn't represent a pull request" ref))])) 93 | 94 | 95 | (define (refactoring-result->github-review-comment result) 96 | (define path 97 | (file-source-path (syntax-replacement-source (refactoring-result-syntax-replacement result)))) 98 | (define replacement (refactoring-result-line-replacement result)) 99 | (define body 100 | (format #< 108 | Debugging details 109 | 110 |
111 | Textual replacement 112 | 113 | ```scheme 114 | ~a 115 | ``` 116 |
117 | 118 |
119 | Syntactic replacement 120 | 121 | ```scheme 122 | ~a 123 | ``` 124 |
125 | 126 | EOS 127 | (refactoring-result-rule-name result) 128 | (refactoring-result-message result) 129 | (line-replacement-new-text replacement) 130 | (string-indent (pretty-format replacement) #:amount 2) 131 | (string-indent (pretty-format (refactoring-result-syntax-replacement result)) 132 | #:amount 2))) 133 | (github-review-comment 134 | #:path (first (git-path path)) 135 | #:body body 136 | #:start-line (line-replacement-start-line replacement) 137 | #:end-line (line-replacement-original-end-line replacement) 138 | #:start-side "RIGHT" 139 | #:end-side "RIGHT")) 140 | 141 | 142 | (define branch-ref (getenv "GITHUB_REF")) 143 | (define github-repository (getenv "GITHUB_REPOSITORY")) 144 | 145 | 146 | (define (github-review-body comments? file-count) 147 | (format "[Resyntax](https://docs.racket-lang.org/resyntax/) analyzed ~a in this pull request and ~a" 148 | (if (= file-count 1) "1 file" (format "~a files" file-count)) 149 | (if comments? "has added suggestions." "found no issues."))) 150 | 151 | 152 | (define (refactoring-results->github-review results #:file-count file-count) 153 | (define comments 154 | (transduce results (mapping refactoring-result->github-review-comment) #:into into-list)) 155 | (github-review-request 156 | #:owner-repo github-repository 157 | #:pull-number (git-ref->pr-number branch-ref) 158 | #:body (github-review-body (not (null? comments)) file-count) 159 | #:event (if (empty? comments) "APPROVE" "COMMENT") 160 | #:comments comments)) 161 | -------------------------------------------------------------------------------- /private/identifier-naming.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [depluralize-id (-> identifier? identifier?)])) 10 | 11 | 12 | (require racket/string 13 | racket/syntax) 14 | 15 | 16 | ;@---------------------------------------------------------------------------------------------------- 17 | 18 | 19 | (define (depluralize-id id) 20 | (define plural-name (symbol->string (syntax-e id))) 21 | (define singular-name 22 | (cond 23 | [(string-suffix? plural-name "es") (string-trim plural-name "es" #:left? #false)] 24 | [(string-suffix? plural-name "s") (string-trim plural-name "s" #:left? #false)] 25 | [else plural-name])) 26 | (format-id id "~a" (string->symbol singular-name))) 27 | -------------------------------------------------------------------------------- /private/limiting.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [limiting (-> (>=/c 0) #:by (-> any/c (>=/c 0)) transducer?)])) 10 | 11 | 12 | (require rebellion/base/variant 13 | rebellion/streaming/transducer) 14 | 15 | 16 | (module+ test 17 | (require racket/match 18 | rackunit 19 | rebellion/collection/list 20 | (submod ".."))) 21 | 22 | 23 | ;@---------------------------------------------------------------------------------------------------- 24 | 25 | 26 | (struct limiting-emit-state (weight-so-far element) #:transparent) 27 | 28 | 29 | (define (limiting max-weight #:by weight-function) 30 | 31 | (define (start) 32 | (variant #:consume 0)) 33 | 34 | (define (consume weight-so-far v) 35 | (define new-weight (+ weight-so-far (weight-function v))) 36 | (cond 37 | [(< new-weight max-weight) (variant #:emit (limiting-emit-state new-weight v))] 38 | [(> new-weight max-weight) (variant #:consume weight-so-far)] 39 | [else (variant #:half-closed-emit v)])) 40 | 41 | (define (emit s) 42 | (define weight-so-far (limiting-emit-state-weight-so-far s)) 43 | 44 | (emission (variant #:consume weight-so-far) (limiting-emit-state-element s))) 45 | 46 | (define (half-closed-emit v) 47 | (half-closed-emission (variant #:finish #false) v)) 48 | 49 | (make-transducer #:starter start 50 | #:consumer consume 51 | #:emitter emit 52 | #:half-closer (λ (_) (variant #:finish #false)) 53 | #:half-closed-emitter half-closed-emit 54 | #:finisher void 55 | #:name 'limiting)) 56 | 57 | 58 | (module+ test 59 | (test-case "limiting" 60 | (define inputs (list 'small 'big 'medium 'medium 'big 'small)) 61 | 62 | (define (weight i) 63 | (match i 64 | ['small 1] 65 | ['medium 5] 66 | ['big 10])) 67 | 68 | (check-equal? (transduce inputs (limiting 3 #:by weight) #:into into-list) (list 'small 'small)) 69 | (check-equal? (transduce inputs (limiting 13 #:by weight) #:into into-list) 70 | (list 'small 'big 'small)) 71 | (check-equal? (transduce inputs (limiting 16 #:by weight) #:into into-list) 72 | (list 'small 'big 'medium)) 73 | (check-equal? (transduce inputs (limiting +inf.0 #:by weight) #:into into-list) 74 | (list 'small 'big 'medium 'medium 'big 'small)) 75 | (check-equal? (transduce (list 'small 'big 'small 'big 'small 'big 'small 'big 'small 'big) 76 | (limiting 3 #:by weight) 77 | #:into into-list) 78 | (list 'small 'small 'small)) 79 | (check-equal? (transduce (list 'small 'big 'small 'big 'small 'big 'small 'big 'small 'big) 80 | (limiting 5 #:by weight) 81 | #:into into-list) 82 | (list 'small 'small 'small 'small 'small)))) 83 | -------------------------------------------------------------------------------- /private/line-replacement.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [line-replacement 10 | (-> #:start-line exact-positive-integer? 11 | #:original-lines (sequence/c string?) 12 | #:new-lines (sequence/c string?) 13 | line-replacement?)] 14 | [line-replacement? (-> any/c boolean?)] 15 | [line-replacement-start-line (-> line-replacement? exact-positive-integer?)] 16 | [line-replacement-original-end-line (-> line-replacement? exact-positive-integer?)] 17 | [line-replacement-original-lines 18 | (-> line-replacement? (vectorof (and/c string? immutable?) #:immutable #true #:flat? #true))] 19 | [line-replacement-new-end-line (-> line-replacement? exact-positive-integer?)] 20 | [line-replacement-new-lines 21 | (-> line-replacement? (vectorof (and/c string? immutable?) #:immutable #true #:flat? #true))] 22 | [line-replacement-new-text (-> line-replacement? (and/c string? immutable?))] 23 | [string-replacement->line-replacement (-> string-replacement? string? line-replacement?)])) 24 | 25 | 26 | (require racket/sequence 27 | rebellion/streaming/reducer 28 | rebellion/streaming/transducer 29 | rebellion/type/record 30 | resyntax/private/linemap 31 | resyntax/private/string-replacement) 32 | 33 | 34 | (module+ test 35 | (require rackunit 36 | (submod ".."))) 37 | 38 | 39 | ;@---------------------------------------------------------------------------------------------------- 40 | 41 | 42 | (define-record-type line-replacement (start-line original-lines new-lines) 43 | #:omit-root-binding) 44 | 45 | 46 | (define (line-replacement #:start-line start-line 47 | #:original-lines original-lines 48 | #:new-lines new-lines) 49 | (define immutable-original-lines 50 | (for/vector ([line original-lines]) 51 | (string->immutable-string line))) 52 | (define immutable-new-lines 53 | (for/vector ([line new-lines]) 54 | (string->immutable-string line))) 55 | (constructor:line-replacement #:start-line start-line 56 | #:original-lines immutable-original-lines 57 | #:new-lines immutable-new-lines)) 58 | 59 | 60 | (define (line-replacement-original-end-line replacement) 61 | (+ (line-replacement-start-line replacement) 62 | (sub1 (vector-length (line-replacement-original-lines replacement))))) 63 | 64 | 65 | (define (line-replacement-new-end-line replacement) 66 | (+ (line-replacement-start-line replacement) 67 | (sub1 (vector-length (line-replacement-new-lines replacement))))) 68 | 69 | 70 | (define (line-replacement-new-text replacement) 71 | (transduce (line-replacement-new-lines replacement) #:into (join-into-string "\n"))) 72 | 73 | 74 | (define (string-replacement->line-replacement replacement original-string) 75 | (define new-string (string-apply-replacement original-string replacement)) 76 | (define orig-lmap (string-linemap original-string)) 77 | (define new-lmap (string-linemap new-string)) 78 | 79 | (define start-line 80 | (linemap-position-to-line orig-lmap (add1 (string-replacement-start replacement)))) 81 | (define start-pos 82 | (sub1 83 | (linemap-position-to-start-of-line orig-lmap (add1 (string-replacement-start replacement))))) 84 | (define original-end-pos 85 | (sub1 86 | (linemap-position-to-end-of-line orig-lmap 87 | (add1 (string-replacement-original-end replacement))))) 88 | (define new-end-pos 89 | (sub1 (linemap-position-to-end-of-line new-lmap (add1 (string-replacement-new-end replacement))))) 90 | 91 | (define original-substr (substring original-string start-pos original-end-pos)) 92 | (define new-substr (substring new-string start-pos new-end-pos)) 93 | (line-replacement #:start-line start-line 94 | #:original-lines (in-lines (open-input-string original-substr)) 95 | #:new-lines (in-lines (open-input-string new-substr)))) 96 | 97 | 98 | (module+ test 99 | (test-case "string-replacement->line-replacement" 100 | 101 | (test-case "multiple middle lines" 102 | (define s "hello\nworld\nhow are you\ntoday?") 103 | (define middle-of-world-index 8) 104 | (define start-of-are-you-index 16) 105 | (check-equal? (substring s middle-of-world-index start-of-are-you-index) "rld\nhow ") 106 | (define str-replacement 107 | (string-replacement #:start middle-of-world-index 108 | #:end start-of-are-you-index 109 | #:contents (list (inserted-string "RLD HOW ")))) 110 | (check-equal? (string-replacement->line-replacement str-replacement s) 111 | (line-replacement #:start-line 2 112 | #:original-lines (list "world" "how are you") 113 | #:new-lines (list "woRLD HOW are you")))) 114 | 115 | (test-case "entire string replacement" 116 | (define s "hello\nworld\nhow are you\ntoday?") 117 | (define str-replacement 118 | (string-replacement #:start 0 119 | #:end (string-length s) 120 | #:contents (list (inserted-string "hello world")))) 121 | (check-equal? (string-replacement->line-replacement str-replacement s) 122 | (line-replacement #:start-line 1 123 | #:original-lines (list "hello" "world" "how are you" "today?") 124 | #:new-lines (list "hello world")))))) 125 | -------------------------------------------------------------------------------- /private/logger.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide log-resyntax-fatal 5 | log-resyntax-error 6 | log-resyntax-warning 7 | log-resyntax-info 8 | log-resyntax-debug 9 | resyntax-logger) 10 | 11 | 12 | (define-logger resyntax) 13 | -------------------------------------------------------------------------------- /private/more-syntax-parse-classes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide syntax-parse-option 5 | syntax-parse-pattern-directive) 6 | 7 | 8 | (require syntax/parse) 9 | 10 | 11 | ;@---------------------------------------------------------------------------------------------------- 12 | 13 | 14 | (define-splicing-syntax-class syntax-parse-option 15 | (pattern (~seq #:context ~! context-expr:expr)) 16 | (pattern (~seq #:literals ~! (literal:syntax-parse-literal ...))) 17 | (pattern (~seq #:datum-literals ~! (datum-literal:syntax-parse-datum-literal ...))) 18 | (pattern (~seq #:literal-sets ~! (literal-set:syntax-parse-literal-set ...))) 19 | (pattern #:track-literals) 20 | (pattern (~seq #:conventions ~! (convention-id:id ...))) 21 | (pattern (~seq #:local-conventions ~! (convention-id:id ...))) 22 | (pattern #:disable-colon-notation)) 23 | 24 | 25 | (define-syntax-class syntax-parse-literal 26 | (pattern literal-id:id) 27 | (pattern (pattern-id:id literal-id:id)) 28 | (pattern (pattern-id:id literal-id:id #:phase phase-expr:expr))) 29 | 30 | 31 | (define-syntax-class syntax-parse-datum-literal 32 | (pattern literal-id:id) 33 | (pattern (pattern-id:id literal-id:id))) 34 | 35 | 36 | (define-syntax-class syntax-parse-literal-set 37 | (pattern literal-set-id:id) 38 | (pattern (literal-set-id:id literal-set-option:syntax-parse-literal-set-option ...))) 39 | 40 | 41 | (define-splicing-syntax-class syntax-parse-literal-set-option 42 | (pattern (~seq #:at context-id:id)) 43 | (pattern (~seq #:phase phase-expr:expr))) 44 | 45 | 46 | (define-splicing-syntax-class syntax-parse-pattern-directive 47 | (pattern (~seq #:declare ~! pvar-id:id 48 | (~or syntax-class-id:id (syntax-class-id:id arg ...)) 49 | (~optional (~seq #:role role-expr:expr)))) 50 | (pattern (~seq #:post ~! action-pattern)) 51 | (pattern (~seq #:and ~! action-pattern)) 52 | (pattern (~seq #:with ~! syntax-pattern stx-expr:expr)) 53 | (pattern (~seq #:attr ~! (~or attr-name-id:id (attr-name-id:id depth)) expr:expr)) 54 | (pattern (~seq #:fail-when ~! condition-expr:expr message-expr:expr)) 55 | (pattern (~seq #:fail-unless ~! condition-expr:expr message-expr:expr)) 56 | (pattern (~seq #:when ~! condition-expr:expr)) 57 | (pattern (~seq #:do ~! [defn-or-expr ...])) 58 | (pattern (~seq #:undo ~! [defn-or-expr ...])) 59 | (pattern #:cut)) 60 | -------------------------------------------------------------------------------- /private/run-command.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [run-command (-> string? path-string? ... string?)])) 10 | 11 | 12 | (require racket/port 13 | racket/string 14 | rebellion/private/static-name) 15 | 16 | 17 | ;@---------------------------------------------------------------------------------------------------- 18 | 19 | 20 | ; This doesn't support anything but getting stdout -- but that's OK for now! 21 | (define (run-command cmd-name . args) 22 | (define stringified-args (map (λ (arg) (if (path? arg) (path->string arg) arg)) args)) 23 | (define cmd-path 24 | (or (find-executable-path cmd-name) 25 | ; Racket doesn't know about $PATHEXT: 26 | (find-executable-path (string-append cmd-name ".exe")))) 27 | (unless cmd-path 28 | (raise-arguments-error (name run-command) 29 | "couldn't find executable in $PATH" 30 | "executable" cmd-name)) 31 | (define-values (proc stdout stdin stderr) 32 | (apply subprocess #f #f #f cmd-path args)) 33 | (close-output-port stdin) 34 | (subprocess-wait proc) 35 | (define exit-code (subprocess-status proc)) 36 | (define stdout-string (port->string stdout)) 37 | (define stderr-string (string-trim (port->string stderr))) 38 | (close-input-port stdout) 39 | (close-input-port stderr) 40 | (unless (zero? exit-code) 41 | (raise-arguments-error (name run-command) 42 | "command exited with a nonzero exit code" 43 | "command" (string-join (cons cmd-name stringified-args) " ") 44 | "exit code" exit-code 45 | "stderr" stderr-string)) 46 | (when (non-empty-string? stderr-string) 47 | (raise-arguments-error (name run-command) 48 | "command exited successfully, but wrote to stderr" 49 | "command" (string-join (cons cmd-name stringified-args) " ") 50 | "stderr" stderr-string)) 51 | stdout-string) 52 | -------------------------------------------------------------------------------- /private/scribble-evaluator-factory.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module doc racket/base 5 | 6 | 7 | (require racket/contract/base) 8 | 9 | 10 | (provide 11 | (contract-out 12 | [evaluator/c contract?] 13 | [evaluator-factory? (-> any/c boolean?)] 14 | [evaluator-factory-create (-> evaluator-factory? evaluator/c)] 15 | [make-module-sharing-evaluator-factory 16 | (->* () 17 | (#:private (listof module-path?) 18 | #:public (listof module-path?)) 19 | evaluator-factory?)])) 20 | 21 | 22 | (require racket/list 23 | scribble/example) 24 | 25 | 26 | ;@---------------------------------------------------------------------------- 27 | 28 | 29 | (define evaluator/c (-> any/c any/c)) 30 | 31 | 32 | (struct evaluator-factory (thunk) 33 | #:constructor-name make-evaluator-factory 34 | #:property prop:procedure 0) 35 | 36 | 37 | (define (evaluator-factory-create factory) 38 | ((evaluator-factory-thunk factory))) 39 | 40 | 41 | (define (make-module-sharing-evaluator-factory 42 | #:public [public-modules empty] 43 | #:private [private-modules empty]) 44 | (define base-factory 45 | (make-base-eval-factory (append private-modules public-modules))) 46 | (define (factory) 47 | (define evaluator (base-factory)) 48 | (evaluator `(require ,@public-modules)) 49 | evaluator) 50 | (make-evaluator-factory factory))) 51 | -------------------------------------------------------------------------------- /private/string-indent.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [string-indent (-> string? #:amount exact-nonnegative-integer? (and/c string? immutable?))] 10 | [string-hanging-indent 11 | (-> string? #:amount exact-nonnegative-integer? (and/c string? immutable?))])) 12 | 13 | 14 | (require racket/string) 15 | 16 | 17 | ;@---------------------------------------------------------------------------------------------------- 18 | 19 | 20 | (define (string-indent s #:amount amount) 21 | (define lines 22 | (for/list ([line (in-lines (open-input-string s))]) 23 | (string-append (make-string amount #\space) line))) 24 | (string->immutable-string (string-join lines "\n"))) 25 | 26 | 27 | (define (string-hanging-indent s #:amount amount) 28 | (define lines 29 | (for/list ([line (in-lines (open-input-string s))] 30 | [i (in-naturals)]) 31 | (if (zero? i) 32 | line 33 | (string-append (make-string amount #\space) line)))) 34 | (string->immutable-string (string-join lines "\n"))) 35 | -------------------------------------------------------------------------------- /private/syntax-range.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [syntax-source-range (-> (and/c syntax? syntax-has-position? syntax-has-span?) range?)])) 10 | 11 | 12 | (require rebellion/base/comparator 13 | rebellion/base/range) 14 | 15 | 16 | ;@---------------------------------------------------------------------------------------------------- 17 | 18 | 19 | (define (syntax-has-position? stx) 20 | (and (syntax-position stx) #true)) 21 | 22 | 23 | (define (syntax-has-span? stx) 24 | (and (syntax-span stx) #true)) 25 | 26 | 27 | (define (syntax-source-range stx) 28 | (closed-open-range (syntax-position stx) (+ (syntax-position stx) (syntax-span stx)) 29 | #:comparator natural<=>)) 30 | -------------------------------------------------------------------------------- /private/syntax-traversal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | syntax-traverse 9 | (contract-out 10 | [leaves-in-syntax (->* (syntax?) ((-> syntax? boolean?)) (sequence/c syntax?))] 11 | [syntax-directly-enclosing-expressions (-> syntax? identifier? (listof syntax?))])) 12 | 13 | 14 | (require (for-syntax racket/base 15 | resyntax/private/more-syntax-parse-classes) 16 | racket/match 17 | racket/sequence 18 | racket/stream 19 | syntax/parse 20 | syntax/parse/define) 21 | 22 | 23 | (module+ test 24 | (require rackunit 25 | (submod ".."))) 26 | 27 | 28 | ;@---------------------------------------------------------------------------------------------------- 29 | 30 | 31 | (define (leaves-in-syntax stx [leaf? flat-syntax?]) 32 | (stream* 33 | (match stx 34 | [(? leaf?) (stream stx)] 35 | [(app syntax-e (and stx-list (or '() (? pair?)))) (leaves-in-syntax-pair stx-list leaf?)] 36 | [(app syntax-e (box substx)) (leaves-in-syntax substx leaf?)] 37 | [else (stream)]))) 38 | 39 | 40 | (define (leaves-in-syntax-pair stx-list [leaf? flat-syntax?]) 41 | (stream* 42 | (match stx-list 43 | ['() (stream)] 44 | [(cons head '()) (leaves-in-syntax head leaf?)] 45 | [(cons head (? syntax? tail)) 46 | (stream-append (leaves-in-syntax head leaf?) (leaves-in-syntax tail leaf?))] 47 | [(cons head (? pair? tail)) 48 | (stream-append (leaves-in-syntax head leaf?) (leaves-in-syntax-pair tail leaf?))]))) 49 | 50 | 51 | (define (flat-syntax? stx) 52 | (define datum (syntax-e stx)) 53 | (or (symbol? datum) 54 | (number? datum) 55 | (string? datum) 56 | (boolean? datum) 57 | (regexp? datum) 58 | (keyword? datum))) 59 | 60 | 61 | (define (syntax-directly-enclosing-expressions stx id) 62 | 63 | (define (directly-encloses? subform) 64 | (syntax-parse subform 65 | [(part ...) 66 | (for/or ([part-stx (in-list (attribute part))]) 67 | (and (identifier? part-stx) (free-identifier=? id part-stx)))] 68 | [(part ... . tail-part) 69 | (for/or ([part-stx (in-list (cons #'tail-part (attribute part)))]) 70 | (and (identifier? part-stx) (free-identifier=? id part-stx)))] 71 | [_ #false])) 72 | 73 | (sequence->list (leaves-in-syntax stx directly-encloses?))) 74 | 75 | 76 | (define-syntax-parse-rule 77 | (syntax-traverse (~var stx-expr (expr/c #'syntax?)) 78 | option:syntax-parse-option ... 79 | [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...] ...) 80 | (let () 81 | (define-syntax-class traversal-case 82 | #:attributes (traversed) 83 | (~@ . option) ... 84 | (pattern clause-pattern (~@ . directive) ... 85 | #:attr traversed (let () clause-body ...)) ...) 86 | (let loop ([stx stx-expr.c]) 87 | (syntax-parse stx 88 | [(~var matched traversal-case) (attribute matched.traversed)] 89 | 90 | [(part (... ...)) 91 | #:cut 92 | #:with (traversed-part (... ...)) (map loop (attribute part)) 93 | #'(traversed-part (... ...))] 94 | [(part (... ...+) . tail-part) 95 | #:cut 96 | #:with (traversed-part (... ...)) (map loop (attribute part)) 97 | #:with traversed-tail (loop #'tail-part) 98 | #'(traversed-part (... ...) . traversed-tail)] 99 | [_ stx])))) 100 | 101 | 102 | (module+ test 103 | (test-case "syntax-traverse" 104 | (define stx 105 | #'(define (foo) 106 | (cons x y) 107 | (define (bar) 108 | (cons a b)) 109 | (cons c d))) 110 | (define actual 111 | (syntax->datum 112 | (syntax-traverse stx 113 | #:literals (cons) 114 | [(cons _ _) #'CONS-EXPRESSION]))) 115 | (define expected 116 | '(define (foo) 117 | CONS-EXPRESSION 118 | (define (bar) 119 | CONS-EXPRESSION) 120 | CONS-EXPRESSION)) 121 | (check-equal? actual expected))) 122 | -------------------------------------------------------------------------------- /test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide #%app 5 | #%datum 6 | #%module-begin 7 | begin 8 | code-block 9 | header: 10 | line-range 11 | range-set 12 | require: 13 | statement 14 | test:) 15 | 16 | 17 | (require (for-syntax racket/base 18 | racket/sequence 19 | resyntax/test/private/statement) 20 | racket/stxparam 21 | rackunit 22 | rebellion/base/comparator 23 | rebellion/base/range 24 | rebellion/collection/range-set 25 | resyntax/test/private/rackunit 26 | syntax/parse/define) 27 | 28 | 29 | ;@---------------------------------------------------------------------------------------------------- 30 | 31 | 32 | (define-syntax (statement stx) 33 | (syntax-parse stx 34 | #:track-literals 35 | [(statement statement-id:id . tail) 36 | #:do [(syntax-parse-state-cons! 'literas #'statement-id)] 37 | (define transformer (syntax-local-value #'statement-id (λ () #false))) 38 | (unless transformer 39 | (raise-syntax-error #false 40 | "unbound identifier" 41 | this-syntax 42 | #'statement-id)) 43 | (unless (statement-transformer? transformer) 44 | (raise-syntax-error #false 45 | "not defined as a statement" 46 | this-syntax 47 | #'statement-id)) 48 | (syntax-local-apply-transformer (statement-transformer-procedure transformer) 49 | #'statement-id 50 | 'module 51 | #false 52 | stx)])) 53 | 54 | 55 | (define-syntax require: 56 | (statement-transformer 57 | (λ (stx) 58 | (syntax-parse stx 59 | #:track-literals 60 | [(_ _ module:id suite:id) 61 | #`(begin 62 | (require (only-in module suite)) 63 | ; Using syntax/loc to ensure that if add-suite-under-test! throws a runtime 64 | ; error because suite isn't a refactoring suite, the error will point to the 65 | ; require: statement. 66 | #,(syntax/loc this-syntax (add-suite-under-test! suite)))])))) 67 | 68 | 69 | (begin-for-syntax 70 | (define-syntax-class literal-code-block 71 | #:description "a code block" 72 | #:opaque 73 | #:literals (code-block) 74 | (pattern (code-block str:str)))) 75 | 76 | 77 | (define-syntax header: 78 | (statement-transformer 79 | (λ (stx) 80 | (syntax-parse stx 81 | #:track-literals 82 | [(_ _ header-code:literal-code-block) 83 | ; Using syntax/loc so that errors thrown by set-header! point to the header: 84 | ; statement. 85 | (syntax/loc stx (set-header! header-code))])))) 86 | 87 | 88 | (begin-for-syntax 89 | (define-splicing-syntax-class test-parameters 90 | #:attributes ([id 1] [value 1]) 91 | #:literals (range-set) 92 | #:datum-literals (option @lines) 93 | 94 | (pattern (~seq) 95 | #:with (id ...) '() 96 | #:with (value ...) '()) 97 | 98 | (pattern (~seq (option @lines (~and line-set (range-set . _)))) 99 | #:with (id ...) (list #'current-line-mask) 100 | #:with (value ...) (list #'line-set))) 101 | 102 | (define-splicing-syntax-class code-block-test-args 103 | #:attributes ([check 1]) 104 | 105 | (pattern code:literal-code-block 106 | #:with (check ...) 107 | (list (syntax/loc #'code (check-suite-does-not-refactor code)))) 108 | 109 | (pattern (~seq input-code:literal-code-block expected-code:literal-code-block) 110 | #:with (check ...) 111 | (list (syntax/loc #'input-code (check-suite-refactors input-code expected-code)))) 112 | 113 | (pattern (~seq input-code:literal-code-block ...+ 114 | expected-code:literal-code-block) 115 | #:when (>= (length (attribute input-code)) 2) 116 | #:with (check ...) 117 | (for/list ([input-stx (in-list (attribute input-code))]) 118 | (quasisyntax/loc input-stx 119 | (check-suite-refactors #,input-stx expected-code)))))) 120 | 121 | 122 | (define-syntax test: 123 | (statement-transformer 124 | (λ (stx) 125 | (syntax-parse stx 126 | #:track-literals 127 | [(_ _ name:str params:test-parameters args:code-block-test-args) 128 | #`(test-case name 129 | (parameterize ([params.id params.value] ...) 130 | args.check ...))])))) 131 | 132 | 133 | (define (line-range first-line last-line) 134 | (closed-range first-line last-line #:comparator natural<=>)) 135 | 136 | 137 | ;@---------------------------------------------------------------------------------------------------- 138 | 139 | 140 | (module reader racket/base 141 | 142 | 143 | (require racket/contract/base) 144 | 145 | 146 | (provide 147 | (contract-out 148 | [read procedure?] 149 | [read-syntax procedure?])) 150 | 151 | 152 | (require resyntax/test/private/grammar 153 | resyntax/test/private/tokenizer) 154 | 155 | 156 | ;@-------------------------------------------------------------------------------------------------- 157 | 158 | 159 | (define (read in) 160 | (read-using-syntax-reader read-syntax in)) 161 | 162 | 163 | (define (read-syntax source-name in) 164 | (define parse-tree (parse source-name (make-refactoring-test-tokenizer in))) 165 | (define module-datum 166 | `(module refactoring-test racket/base 167 | (module test resyntax/test 168 | ,parse-tree))) 169 | (datum->syntax #f module-datum)) 170 | 171 | 172 | (define (read-using-syntax-reader syntax-reader in) 173 | (syntax->datum (syntax-reader #false in)))) 174 | -------------------------------------------------------------------------------- /test/private/grammar.rkt: -------------------------------------------------------------------------------- 1 | #lang brag 2 | 3 | begin: statement* 4 | statement: COLON-IDENTIFIER (option | code-block | expression)+ 5 | @expression: range-set | IDENTIFIER | LITERAL-STRING | LITERAL-INTEGER 6 | option: AT-SIGN-IDENTIFIER expression 7 | code-block: CODE-BLOCK 8 | range-set: line-range (/COMMA line-range)* 9 | line-range: LITERAL-INTEGER /DOUBLE-DOT LITERAL-INTEGER 10 | -------------------------------------------------------------------------------- /test/private/statement.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide (struct-out statement-transformer)) 5 | 6 | 7 | ;@---------------------------------------------------------------------------------------------------- 8 | 9 | 10 | (struct statement-transformer (procedure)) 11 | -------------------------------------------------------------------------------- /test/private/tokenizer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [make-refactoring-test-tokenizer (-> input-port? (-> (or/c position-token? eof-object?)))])) 10 | 11 | 12 | (require br-parser-tools/lex 13 | racket/block 14 | racket/list 15 | racket/string) 16 | 17 | 18 | (module+ test 19 | (require brag/support 20 | rackunit 21 | (submod ".."))) 22 | 23 | 24 | ;@---------------------------------------------------------------------------------------------------- 25 | 26 | 27 | (define-lex-abbrev refactoring-test-separator-line 28 | (concatenation (repetition 3 +inf.0 #\-))) 29 | 30 | 31 | (define-lex-abbrev refactoring-test-code-block 32 | (concatenation refactoring-test-separator-line 33 | (complement (concatenation any-string #\newline "-" any-string)) 34 | #\newline 35 | refactoring-test-separator-line)) 36 | 37 | 38 | (define-lex-abbrev refactoring-test-code-line 39 | (concatenation #\- #\space (complement (concatenation any-string #\newline any-string)) #\newline)) 40 | 41 | 42 | (define-lex-abbrev refactoring-test-literal-string 43 | (concatenation #\" (complement (concatenation any-string #\" any-string)) #\")) 44 | 45 | 46 | (define-lex-abbrev refactoring-test-literal-integer 47 | (repetition 1 +inf.0 numeric)) 48 | 49 | 50 | (define-lex-abbrev refactoring-test-identifier 51 | (concatenation alphabetic 52 | (repetition 0 +inf.0 (union alphabetic numeric (char-set "-/"))))) 53 | 54 | 55 | (define-tokens refactoring-test-tokens 56 | (IDENTIFIER COLON-IDENTIFIER AT-SIGN-IDENTIFIER LITERAL-STRING LITERAL-INTEGER CODE-BLOCK)) 57 | (define-empty-tokens empty-refactoring-test-tokens (DOUBLE-DOT COMMA)) 58 | 59 | 60 | (define (string-lines str) 61 | (for/list ([line (in-lines (open-input-string str))]) 62 | (string->immutable-string line))) 63 | 64 | 65 | (define refactoring-test-lexer 66 | (lexer-src-pos 67 | [whitespace (return-without-pos (refactoring-test-lexer input-port))] 68 | [".." (token-DOUBLE-DOT)] 69 | ["," (token-COMMA)] 70 | [refactoring-test-code-line (token-CODE-BLOCK (string->immutable-string (substring lexeme 2)))] 71 | [refactoring-test-code-block 72 | (block 73 | (define lines (drop-right (drop (string-lines lexeme) 1) 1)) 74 | (token-CODE-BLOCK 75 | (if (empty? lines) "" (string->immutable-string (string-join lines "\n" #:after-last "\n")))))] 76 | [refactoring-test-literal-string 77 | (token-LITERAL-STRING 78 | (string->immutable-string (substring lexeme 1 (sub1 (string-length lexeme)))))] 79 | [refactoring-test-literal-integer (token-LITERAL-INTEGER (string->number lexeme))] 80 | [(concatenation refactoring-test-identifier ":") 81 | (token-COLON-IDENTIFIER (string->symbol lexeme))] 82 | [(concatenation "@" refactoring-test-identifier) 83 | (token-AT-SIGN-IDENTIFIER (string->symbol lexeme))] 84 | [refactoring-test-identifier (token-IDENTIFIER (string->symbol lexeme))])) 85 | 86 | 87 | (define ((make-refactoring-test-tokenizer port)) 88 | (refactoring-test-lexer port)) 89 | 90 | 91 | (module+ test 92 | (test-case "make-refactoring-test-tokenizer" 93 | 94 | (test-case "statements" 95 | (define input (open-input-string "header:\n- #lang racket\n")) 96 | (port-count-lines! input) 97 | (define tokenizer (make-refactoring-test-tokenizer input)) 98 | (check-equal? (tokenizer) 99 | (position-token (token-COLON-IDENTIFIER 'header:) 100 | (position 1 1 0) 101 | (position 8 1 7))) 102 | (check-equal? (tokenizer) 103 | (position-token (token-CODE-BLOCK "#lang racket\n") 104 | (position 9 2 0) 105 | (position 24 3 0)))) 106 | 107 | (test-case "code blocks" 108 | (define input (open-input-string "---\n#lang racket/base\n(void)\n---")) 109 | (port-count-lines! input) 110 | (define tokenizer (make-refactoring-test-tokenizer input)) 111 | (define expected-token 112 | (position-token 113 | (token-CODE-BLOCK "#lang racket/base\n(void)\n") 114 | (position 1 1 0) 115 | (position 33 4 3))) 116 | (check-equal? (tokenizer) expected-token)) 117 | 118 | (test-case "empty code blocks" 119 | (define input (open-input-string "---\n---")) 120 | (port-count-lines! input) 121 | (define tokenizer (make-refactoring-test-tokenizer input)) 122 | (define expected-token 123 | (position-token 124 | (token-CODE-BLOCK "") 125 | (position 1 1 0) 126 | (position 8 2 3))) 127 | (check-equal? (tokenizer) expected-token)) 128 | 129 | (test-case "code lines" 130 | (define input (open-input-string "- #lang racket/base (void)\n")) 131 | (port-count-lines! input) 132 | (define tokenizer (make-refactoring-test-tokenizer input)) 133 | (define expected-token 134 | (position-token 135 | (token-CODE-BLOCK "#lang racket/base (void)\n") 136 | (position 1 1 0) 137 | (position 28 2 0))) 138 | (check-equal? (tokenizer) expected-token)) 139 | 140 | (test-case "multiple code lines" 141 | (define input (open-input-string "- #lang racket/base (f)\n- #lang racket/base (g)\n")) 142 | (port-count-lines! input) 143 | (define tokenizer (make-refactoring-test-tokenizer input)) 144 | (define expected-token 145 | (position-token 146 | (token-CODE-BLOCK "#lang racket/base (f)\n") 147 | (position 1 1 0) 148 | (position 25 2 0))) 149 | (check-equal? (tokenizer) expected-token)))) 150 | --------------------------------------------------------------------------------