Skip to content

Commit

Permalink
More Resyntax cleanups
Browse files Browse the repository at this point in the history
  • Loading branch information
@jackfirth
jackfirth committed Sep 18, 2024
1 parent f663c1d commit 086c58f
Show file tree
Hide file tree
Showing 2 changed files with 49 additions and 54 deletions.
76 changes: 37 additions & 39 deletions private/syntax-neighbors.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,9 +30,9 @@


(module+ test
(require (submod "..")
racket/syntax
rackunit))
(require racket/syntax
rackunit
(submod "..")))


;@----------------------------------------------------------------------------------------------------
Expand Down Expand Up @@ -87,42 +87,40 @@


(define (syntax-originally-neighbors? left-stx* right-stx*)
(let-values ([(left-stx right-stx) (syntax-extract-originals-from-pair left-stx* right-stx*)])
(guarded-block
(define left-trailer (syntax-original-trailing-neighbor left-stx))
(define right-leader (syntax-original-leading-neighbor right-stx))

;; If either of the above is missing, then they're not neighbors. We log a debug message in that
;; case aide in debugging test failures caused by dropped comments.
(guard left-trailer #:else
(log-resyntax-debug (string-append "not neighbors because left-trailer is missing\n"
" original left syntax: ~a\n"
" original right syntax: ~a\n"
" replacement left syntax: ~a\n"
" replacement right syntax: ~a")
(syntax->datum left-stx)
(syntax->datum right-stx)
(syntax->datum left-stx*)
(syntax->datum right-stx*))
#false)
(guard right-leader #:else
(log-resyntax-debug (string-append "not neighbors because right-leader is missing\n"
" original left syntax: ~a\n"
" original right syntax: ~a\n"
" replacement left syntax: ~a\n"
" replacement right syntax: ~a")
(syntax->datum left-stx)
(syntax->datum right-stx)
(syntax->datum left-stx*)
(syntax->datum right-stx*))
#false)
(define left-srcloc (syntax-srcloc left-stx))
(define left-trailer-srcloc (syntax-srcloc left-trailer))
(define right-srcloc (syntax-srcloc right-stx))
(define right-leader-srcloc (syntax-srcloc right-leader))
(guard (and left-srcloc left-trailer-srcloc right-srcloc right-leader-srcloc) #:else #false)
(and (equal? left-trailer-srcloc right-srcloc)
(equal? right-leader-srcloc left-srcloc)))))
(define-values (left-stx right-stx) (syntax-extract-originals-from-pair left-stx* right-stx*))
(guarded-block
(define left-trailer (syntax-original-trailing-neighbor left-stx))
(define right-leader (syntax-original-leading-neighbor right-stx))
;; If either of the above is missing, then they're not neighbors. We log a debug message in that
;; case aide in debugging test failures caused by dropped comments.
(guard left-trailer #:else
(log-resyntax-debug (string-append "not neighbors because left-trailer is missing\n"
" original left syntax: ~a\n"
" original right syntax: ~a\n"
" replacement left syntax: ~a\n"
" replacement right syntax: ~a")
(syntax->datum left-stx)
(syntax->datum right-stx)
(syntax->datum left-stx*)
(syntax->datum right-stx*))
#false)
(guard right-leader #:else
(log-resyntax-debug (string-append "not neighbors because right-leader is missing\n"
" original left syntax: ~a\n"
" original right syntax: ~a\n"
" replacement left syntax: ~a\n"
" replacement right syntax: ~a")
(syntax->datum left-stx)
(syntax->datum right-stx)
(syntax->datum left-stx*)
(syntax->datum right-stx*))
#false)
(define left-srcloc (syntax-srcloc left-stx))
(define left-trailer-srcloc (syntax-srcloc left-trailer))
(define right-srcloc (syntax-srcloc right-stx))
(define right-leader-srcloc (syntax-srcloc right-leader))
(guard (and left-srcloc left-trailer-srcloc right-srcloc right-leader-srcloc) #:else #false)
(and (equal? left-trailer-srcloc right-srcloc) (equal? right-leader-srcloc left-srcloc))))


(module+ test
Expand Down
27 changes: 12 additions & 15 deletions testing/refactoring-test.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,7 @@
refactoring-test-case)


(require (for-syntax racket/base
racket/sequence)
(require (for-syntax racket/base racket/sequence)
racket/list
racket/logging
racket/match
Expand All @@ -35,9 +34,9 @@
resyntax/private/refactoring-result
resyntax/private/source
resyntax/private/string-replacement
syntax/modread
syntax/parse
syntax/parse/define
syntax/modread)
syntax/parse/define)


;@----------------------------------------------------------------------------------------------------
Expand All @@ -59,18 +58,16 @@
(syntax-parser [:id #`#,constant])))


(define-simple-macro
(refactoring-test
import:refactoring-test-import-statement ...
(~optional header:refactoring-test-header-statement)
case ...)
(define-syntax-parse-rule (refactoring-test import:refactoring-test-import-statement ...
(~optional header:refactoring-test-header-statement)
case ...)
#:with parameterization
#'([refactoring-suite-under-test (make-rename-transformer #'suite)]
(~? (~@ [implicit-program-header (make-constant-transformer header.header-block)])))
(begin
import.require-statement ...
(define suite
(refactoring-suite #:rules (append (refactoring-suite-rules import.suite) ...)))
(syntax-parameterize
([refactoring-suite-under-test (make-rename-transformer #'suite)]
(~? (~@ [implicit-program-header (make-constant-transformer header.header-block)])))
(define suite (refactoring-suite #:rules (append (refactoring-suite-rules import.suite) ...)))
(syntax-parameterize parameterization
case ...
;; this void expression ensures that it's not an error if no test cases are given
(void))))
Expand Down Expand Up @@ -163,7 +160,7 @@
(fail-check "no changes were made"))
(when (equal? refactored-program original-program)
(fail-check "fixes were made, but they left the program unchanged"))
(when (not (equal? refactored-program expected-program))
(unless (equal? refactored-program expected-program)
(with-check-info (['original (string-block original-program)])
(fail-check "incorrect changes were made"))))
(match-define (program-output original-stdout original-stderr) (eval-program original-program))
Expand Down

0 comments on commit 086c58f

Please sign in to comment.