jackfirth / resyntax / #78

Committed 30 Oct 2025 02:25AM UTC coverage: 93.533% (-0.05%) from 93.578%

Build # #78

Build Type

push

cover

Committed by

web-flow

Commit Message

Ensure `no-change-test` programs compile (#676)

Run Details

16 of 20 new or added lines in 3 files covered. (80.0%)

4 existing lines in 1 file now uncovered.

14507 of 15510 relevant lines covered (93.53%)

0.94 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

76.09

/test/private/rackunit.rkt

#lang racket/base


(provide (struct-out code-block)
         current-suite-under-test
         current-header
         current-line-mask
         clear-header!
         set-header!
         clear-suites-under-test!
         add-suite-under-test!
         check-suite-refactors
         check-suite-does-not-refactor
         check-suite-analysis)


(require racket/logging
         racket/match
         racket/port
         racket/pretty
         racket/string
         rackunit
         rebellion/base/comparator
         rebellion/base/range
         rebellion/base/result
         rebellion/collection/entry
         rebellion/collection/hash
         rebellion/collection/list
         rebellion/collection/multiset
         rebellion/collection/range-set
         rebellion/collection/vector/builder
         rebellion/streaming/transducer
         rebellion/type/tuple
         resyntax
         resyntax/base
         resyntax/private/logger
         resyntax/private/refactoring-result
         resyntax/private/source
         resyntax/private/string-indent
         resyntax/private/string-replacement
         resyntax/private/syntax-path
         resyntax/private/syntax-property-bundle
         resyntax/private/syntax-traversal
         syntax/modread
         syntax/parse
         (except-in racket/list range))


;@----------------------------------------------------------------------------------------------------


(define (string-block-info s)
  (string-info (string-hanging-indent s #:amount 2)))


(struct code-block (raw-string) #:transparent
  #:guard (λ (raw-string _) (string->immutable-string raw-string))

  #:methods gen:custom-write

  [(define (write-proc this out mode)
     (define raw (code-block-raw-string this))
     (define-values (_line col _pos) (port-next-location out))
     (cond
       [(and (pretty-printing) col)
        (define lead (make-string col #\space))
        (for ([line (in-lines (open-input-string raw))]
              [i (in-naturals)])
          (unless (zero? i)
            (write-string lead out)
            (if (integer? (pretty-print-columns))
                (pretty-print-newline out (pretty-print-columns))
                (newline out)))
          (write-string line out))]
       [else
        (for ([line (in-lines (open-input-string raw))]
              [i (in-naturals)])
          (unless (zero? i)
            (newline out))
          (write-string line out))]))])


(define (code-block-append block1 block2)
  (code-block (string-append (code-block-raw-string block1) (code-block-raw-string block2))))


(define current-suite-under-test (make-parameter (refactoring-suite #:rules '())))


(define (clear-suites-under-test!)
  (current-suite-under-test (refactoring-suite #:rules '())))


(define (add-suite-under-test! suite)
  (define current-rules (refactoring-suite-rules (current-suite-under-test)))
  (define new-rules (append current-rules (refactoring-suite-rules suite)))
  (current-suite-under-test (refactoring-suite #:rules new-rules)))


(define current-header (make-parameter (code-block "")))


(define (clear-header!)
  (current-header (code-block "")))


(define (set-header! header-code)
  (unless (equal? (current-header) (code-block ""))
    (raise-arguments-error 'header: "the header has already been set"))
  (current-header header-code))


(define current-line-mask (make-parameter (range-set (unbounded-range #:comparator natural<=>))))


(define (range-bound-add bound amount)
  (if (unbounded? bound)
      unbounded
      (range-bound (+ (range-bound-endpoint bound) amount) (range-bound-type bound))))


;; Helper function to create logging utilities
(define (make-log-capture-utilities)
  (define logged-messages-builder (make-vector-builder))
  
  (define (save-log log-entry)
    (vector-builder-add logged-messages-builder (vector-ref log-entry 1)))

  (define (call-with-logs-captured proc)
    (with-intercepted-logging save-log #:logger resyntax-logger proc 'debug 'resyntax))

  (define (build-logs-info)
    (string-block-info (string-join (vector->list (build-vector logged-messages-builder)) "\n")))
  
  (values call-with-logs-captured build-logs-info))

;; Helper function to compute the modified line mask based on header
(define (compute-modified-line-mask header-line-count)
  (for/range-set #:comparator natural<=>
    ([r (in-range-set (current-line-mask))])
    (range (range-bound-add (range-lower-bound r) header-line-count)
           (range-bound-add (range-upper-bound r) header-line-count)
           #:comparator natural<=>)))

;; Helper function to create check-info list for matched rules
(define (make-matched-rules-check-info result-set)
  (if (empty? (refactoring-result-set-results result-set))
      '()
      (list (check-info 'matched-rules (refactoring-result-set-matched-rules-info result-set)))))


(define-check (check-suite-refactors original-program expected-program)
  (define suite (current-suite-under-test))
  (set! original-program (code-block-append (current-header) original-program))
  (set! expected-program (code-block-append (current-header) expected-program))
  (define header-line-count
    (count (λ (ch) (equal? ch #\newline)) (string->list (code-block-raw-string (current-header)))))
  (define modified-line-mask (compute-modified-line-mask header-line-count))
  (define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))

  (define result-set
    (call-with-logs-captured
     (λ ()
       (resyntax-analyze (string-source (code-block-raw-string original-program))
                         #:suite suite
                         #:lines modified-line-mask))))
  
  (with-check-info* (make-matched-rules-check-info result-set)
    (λ ()
      (define refactored-program
        (with-handlers
            ([exn:fail?
              (λ (e)
                (with-check-info
                    (['logs (build-logs-info)]
                     ['original (string-block-info (code-block-raw-string original-program))]
                     ['expected (string-block-info expected-program)]
                     ['exception e])
                  (fail-check "an error occurred while processing refactoring results")))])
          (call-with-logs-captured
           (λ () (modified-source-contents (refactoring-result-set-updated-source result-set))))))
      (with-check-info (['logs (build-logs-info)]
                        ['actual (string-block-info refactored-program)]
                        ['expected (string-block-info (code-block-raw-string expected-program))])
        (when (empty? (refactoring-result-set-results result-set))
          (fail-check "no changes were made"))
        (when (equal? refactored-program (code-block-raw-string original-program))
          (fail-check "fixes were made, but they left the program unchanged"))
        (unless (equal? refactored-program (code-block-raw-string expected-program))
          (with-check-info (['original (string-block-info (code-block-raw-string original-program))])
            (fail-check "incorrect changes were made"))))
      (match-define (program-output original-stdout original-stderr)
        (eval-program (code-block-raw-string original-program)))
      (match-define (program-output actual-stdout actual-stderr) (eval-program refactored-program))
      (unless (equal? original-stdout actual-stdout)
        (with-check-info (['logs (build-logs-info)]
                          ['actual (string-block-info actual-stdout)]
                          ['original (string-block-info original-stdout)])
          (fail-check "output to stdout changed")))
      (unless (equal? original-stderr actual-stderr)
        (with-check-info (['logs (build-logs-info)]
                          ['actual (string-block-info actual-stderr)]
                          ['original (string-block-info original-stderr)])
          (fail-check "output to stderr changed"))))))


(define-check (check-suite-does-not-refactor original-program)
  (define suite (current-suite-under-test))
  (set! original-program (code-block-append (current-header) original-program))
  (fail-unless-program-compiles original-program)
  (define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))
  (define result-set
    (call-with-logs-captured
     (λ ()
       (resyntax-analyze (string-source (code-block-raw-string original-program)) #:suite suite))))
  (define refactored-program
    (modified-source-contents (refactoring-result-set-updated-source result-set)))
  (with-check-info* (make-matched-rules-check-info result-set)
    (λ ()
      (with-check-info (['logs (build-logs-info)]
                        ['actual (string-block-info refactored-program)]
                        ['original (string-block-info (code-block-raw-string original-program))])
        (unless (equal? refactored-program (code-block-raw-string original-program))
          (fail-check "expected no changes, but changes were made")))
      (with-check-info (['logs (build-logs-info)]
                        ['actual (string-block-info refactored-program)])
        (unless (empty? (refactoring-result-set-results result-set))
          (fail-check "the program was not changed, but no-op fixes were suggested"))))))


(define (fail-unless-program-compiles program)
  (define src (string-source (code-block-raw-string program)))
  (define expansion-result
    (parameterize ([current-namespace (make-base-namespace)])
      (result (source-expand src))))
  (match expansion-result
    [(? success?) (void)]
    [(failure e)
     (with-check-info (['actual (string-block-info (code-block-raw-string program))]
                       ['exception e])
       (fail-check "the program raised an error when compiled and couldn't be analyzed"))]))


(define-check (check-suite-analysis program context-list target property-key expected-value)
  (define suite (current-suite-under-test))
  (set! program (code-block-append (current-header) program))
  (define program-src (string-source (code-block-raw-string program)))
  (define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))

  (define actual-props
    (call-with-logs-captured
     (λ () (reysntax-analyze-for-properties-only program-src))))

  (define target-src (string-source (string-trim (code-block-raw-string target))))
  (define context-src-list
    (for/list ([ctx (in-list context-list)])
      (string-source (string-trim (code-block-raw-string ctx)))))

  (define target-path (source-find-path-of program-src target-src #:contexts context-src-list))

  (unless target-path
    (with-check-info (['logs (build-logs-info)]
                      ['program (string-block-info (string-source-contents program-src))]
                      ['target (string-block-info (string-source-contents target-src))])
      (fail-check "could not locate target subform within the given program")))

  (define (fail-property-lookup)
    (define target-properties
      (syntax-property-bundle-get-immediate-properties actual-props target-path))
    (with-check-info (['logs (build-logs-info)]
                      ['program (string-block-info (string-source-contents program-src))]
                      ['target (string-block-info (string-source-contents target-src))]
                      ['target-path target-path]
                      ['target-properties target-properties]
                      ['property-key property-key])
      (fail-check "analysis did not assign a value for the given syntax property key")))

  (define actual-value
    (syntax-property-bundle-get-property actual-props target-path property-key fail-property-lookup))

  (unless (equal? actual-value expected-value)
    (with-check-info (['logs (build-logs-info)]
                      ['program (string-block-info (string-source-contents program-src))]
                      ['target (string-block-info (string-source-contents target-src))]
                      ['target-path target-path]
                      ['property-key property-key]
                      ['actual actual-value]
                      ['expected expected-value])
      (fail-check "analysis assigned an incorrect value for the given syntax property key"))))


(define (source-find-path-of src target-src #:contexts [context-srcs '()])
  (define stx (syntax-label-paths (source-read-syntax src) 'source-path))
  (define target-as-string (string-source-contents target-src))

  (define target-stx
    (let loop ([stx stx] [context-srcs context-srcs])
      (match context-srcs
        ['()
         (syntax-find-first stx subform
            #:when (equal? (source-text-of src (attribute subform)) target-as-string))]
        [(cons next-context remaining-contexts)
         (define next-as-string (string-source-contents next-context))
         (define substx
           (syntax-find-first stx subform
             #:when (equal? (source-text-of src (attribute subform)) next-as-string)))
         (and substx (loop substx remaining-contexts))])))
                  
  (and target-stx (syntax-property target-stx 'source-path)))


(module+ test
  (test-case "source-find-path-of"

    (test-case "no #lang"
      (define src (string-source "(+ a b c)"))
      (define target (string-source "b"))
      (check-equal? (source-find-path-of src target) (syntax-path (list 2))))

    (test-case "simple #lang"
      (define src (string-source "#lang racket (define a 1)"))
      (define target (string-source "a"))
      (check-equal? (source-find-path-of src target) (syntax-path (list 3 1 1))))

    (test-case "single context"
      (define src (string-source "(list (+ a) (* a))"))
      (define target (string-source "a"))
      (define contexts (list (string-source "(* a)")))
      (check-equal? (source-find-path-of src target #:contexts contexts) (syntax-path (list 2 1))))

    (test-case "multiple contexts"
      (define src (string-source "(+ a (+ a (+ a (+ a))))"))
      (define target (string-source "a"))
      (define contexts
        (list (string-source "(+ a (+ a (+ a)))")
              (string-source "(+ a (+ a))")
              (string-source "(+ a)")))

      (define actual-path (source-find-path-of src target #:contexts contexts))

      (check-equal? actual-path (syntax-path (list 2 2 2 1))))))


(define (refactoring-result-set-matched-rules-info result-set)
  (define matches
    (transduce (refactoring-result-set-results result-set)
               (mapping refactoring-result-rule-name)
               #:into into-multiset))
  (nested-info
   (transduce (in-hash-entries (multiset-frequencies matches))
              (mapping-values
               (λ (match-count)
                 (string-info (format "~a match~a" match-count (if (= match-count 1) "" "es")))))
              (mapping (λ (e) (check-info (entry-key e) (entry-value e))))
              #:into into-list)))


(define-tuple-type program-output (stdout stderr))


(define (eval-program program)
  (define stdout (open-output-string))
  (define stderr (open-output-string))
  (parameterize ([current-namespace (make-base-namespace)])
    (define (read-from-input)
      (port-count-lines! (current-input-port))
      (with-module-reading-parameterization read-syntax))
    (define stx (with-input-from-string program read-from-input))
    (define module-name
      (syntax-parse stx #:datum-literals (module) [(module name:id _ ...) (syntax-e #'name)]))
    (parameterize ([current-output-port stdout]
                   [current-error-port stderr])
      (eval stx)
      (dynamic-require `',module-name #false)))
  (program-output
   (string->immutable-string (get-output-string stdout))
   (string->immutable-string (get-output-string stderr))))


(module+ test
  (test-case "eval-program"
    (check-equal? (eval-program "#lang racket/base (or 1 2 3)") (program-output "1\n" ""))))

1	#lang racket/base	1✔
2
3
4	(provide (struct-out code-block)	1✔
5	current-suite-under-test	1✔
6	current-header	1✔
7	current-line-mask	1✔
8	clear-header!	1✔
9	set-header!	1✔
10	clear-suites-under-test!	1✔
11	add-suite-under-test!	1✔
12	check-suite-refactors	1✔
13	check-suite-does-not-refactor	1✔
14	check-suite-analysis)	1✔
15
16
17	(require racket/logging	1✔
18	racket/match	1✔
19	racket/port	1✔
20	racket/pretty	1✔
21	racket/string	1✔
22	rackunit	1✔
23	rebellion/base/comparator	1✔
24	rebellion/base/range	1✔
25	rebellion/base/result	1✔
26	rebellion/collection/entry	1✔
27	rebellion/collection/hash	1✔
28	rebellion/collection/list	1✔
29	rebellion/collection/multiset	1✔
30	rebellion/collection/range-set	1✔
31	rebellion/collection/vector/builder	1✔
32	rebellion/streaming/transducer	1✔
33	rebellion/type/tuple	1✔
34	resyntax	1✔
35	resyntax/base	1✔
36	resyntax/private/logger	1✔
37	resyntax/private/refactoring-result	1✔
38	resyntax/private/source	1✔
39	resyntax/private/string-indent	1✔
40	resyntax/private/string-replacement	1✔
41	resyntax/private/syntax-path	1✔
42	resyntax/private/syntax-property-bundle	1✔
43	resyntax/private/syntax-traversal	1✔
44	syntax/modread	1✔
45	syntax/parse	1✔
46	(except-in racket/list range))	1✔
47
48
49	;@----------------------------------------------------------------------------------------------------
50
51
52	(define (string-block-info s)	1✔
53	(string-info (string-hanging-indent s #:amount 2)))	1✔
54
55
56	(struct code-block (raw-string) #:transparent	1✔
57	#:guard (λ (raw-string _) (string->immutable-string raw-string))	1✔
58
59	#:methods gen:custom-write	1✔
60
61	[(define (write-proc this out mode)	1✔
62	(define raw (code-block-raw-string this))	×
63	(define-values (_line col _pos) (port-next-location out))	×
64	(cond	×
65	[(and (pretty-printing) col)	×
66	(define lead (make-string col #\space))	×
67	(for ([line (in-lines (open-input-string raw))]	×
68	[i (in-naturals)])	×
69	(unless (zero? i)	×
70	(write-string lead out)	×
71	(if (integer? (pretty-print-columns))	×
72	(pretty-print-newline out (pretty-print-columns))	×
73	(newline out)))	×
74	(write-string line out))]	×
75	[else	×
76	(for ([line (in-lines (open-input-string raw))]	×
77	[i (in-naturals)])	×
78	(unless (zero? i)	×
79	(newline out))	×
80	(write-string line out))]))])	×
81
82
83	(define (code-block-append block1 block2)	1✔
84	(code-block (string-append (code-block-raw-string block1) (code-block-raw-string block2))))	1✔
85
86
87	(define current-suite-under-test (make-parameter (refactoring-suite #:rules '())))	1✔
88
89
90	(define (clear-suites-under-test!)	1✔
91	(current-suite-under-test (refactoring-suite #:rules '())))	1✔
92
93
94	(define (add-suite-under-test! suite)	1✔
95	(define current-rules (refactoring-suite-rules (current-suite-under-test)))	1✔
96	(define new-rules (append current-rules (refactoring-suite-rules suite)))	1✔
97	(current-suite-under-test (refactoring-suite #:rules new-rules)))	1✔
98
99
100	(define current-header (make-parameter (code-block "")))	1✔
101
102
103	(define (clear-header!)	1✔
104	(current-header (code-block "")))	1✔
105
106
107	(define (set-header! header-code)	1✔
108	(unless (equal? (current-header) (code-block ""))	1✔
109	(raise-arguments-error 'header: "the header has already been set"))	×
110	(current-header header-code))	1✔
111
112
113	(define current-line-mask (make-parameter (range-set (unbounded-range #:comparator natural<=>))))	1✔
114
115
116	(define (range-bound-add bound amount)	1✔
117	(if (unbounded? bound)	1✔
118	unbounded	1✔
119	(range-bound (+ (range-bound-endpoint bound) amount) (range-bound-type bound))))	1✔
120
121
122	;; Helper function to create logging utilities
123	(define (make-log-capture-utilities)	1✔
124	(define logged-messages-builder (make-vector-builder))	1✔
125
126	(define (save-log log-entry)	1✔
127	(vector-builder-add logged-messages-builder (vector-ref log-entry 1)))	1✔
128
129	(define (call-with-logs-captured proc)	1✔
130	(with-intercepted-logging save-log #:logger resyntax-logger proc 'debug 'resyntax))	1✔
131
132	(define (build-logs-info)	1✔
133	(string-block-info (string-join (vector->list (build-vector logged-messages-builder)) "\n")))	1✔
134
135	(values call-with-logs-captured build-logs-info))	1✔
136
137	;; Helper function to compute the modified line mask based on header
138	(define (compute-modified-line-mask header-line-count)	1✔
139	(for/range-set #:comparator natural<=>	1✔
140	([r (in-range-set (current-line-mask))])	1✔
141	(range (range-bound-add (range-lower-bound r) header-line-count)	1✔
142	(range-bound-add (range-upper-bound r) header-line-count)	1✔
143	#:comparator natural<=>)))	1✔
144
145	;; Helper function to create check-info list for matched rules
146	(define (make-matched-rules-check-info result-set)	1✔
147	(if (empty? (refactoring-result-set-results result-set))	1✔
148	'()	1✔
149	(list (check-info 'matched-rules (refactoring-result-set-matched-rules-info result-set)))))	1✔
150
151
152	(define-check (check-suite-refactors original-program expected-program)	1✔
153	(define suite (current-suite-under-test))	1✔
154	(set! original-program (code-block-append (current-header) original-program))	1✔
155	(set! expected-program (code-block-append (current-header) expected-program))	1✔
156	(define header-line-count	1✔
157	(count (λ (ch) (equal? ch #\newline)) (string->list (code-block-raw-string (current-header)))))	1✔
158	(define modified-line-mask (compute-modified-line-mask header-line-count))	1✔
159	(define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))	1✔
160
161	(define result-set	1✔
162	(call-with-logs-captured	1✔
163	(λ ()	1✔
164	(resyntax-analyze (string-source (code-block-raw-string original-program))	1✔
165	#:suite suite	1✔
166	#:lines modified-line-mask))))	1✔
167
168	(with-check-info* (make-matched-rules-check-info result-set)	1✔
169	(λ ()	1✔
170	(define refactored-program	1✔
171	(with-handlers	1✔
172	([exn:fail?	1✔
173	(λ (e)	1✔
174	(with-check-info	×
175	(['logs (build-logs-info)]	×
176	['original (string-block-info (code-block-raw-string original-program))]	×
177	['expected (string-block-info expected-program)]	×
178	['exception e])	×
179	(fail-check "an error occurred while processing refactoring results")))])	×
180	(call-with-logs-captured	1✔
181	(λ () (modified-source-contents (refactoring-result-set-updated-source result-set))))))	1✔
182	(with-check-info (['logs (build-logs-info)]	1✔
183	['actual (string-block-info refactored-program)]	1✔
184	['expected (string-block-info (code-block-raw-string expected-program))])	1✔
185	(when (empty? (refactoring-result-set-results result-set))	1✔
186	(fail-check "no changes were made"))	×
187	(when (equal? refactored-program (code-block-raw-string original-program))	1✔
188	(fail-check "fixes were made, but they left the program unchanged"))	×
189	(unless (equal? refactored-program (code-block-raw-string expected-program))	1✔
190	(with-check-info (['original (string-block-info (code-block-raw-string original-program))])	×
191	(fail-check "incorrect changes were made"))))	×
192	(match-define (program-output original-stdout original-stderr)	1✔
193	(eval-program (code-block-raw-string original-program)))	1✔
194	(match-define (program-output actual-stdout actual-stderr) (eval-program refactored-program))	1✔
195	(unless (equal? original-stdout actual-stdout)	1✔
196	(with-check-info (['logs (build-logs-info)]	×
197	['actual (string-block-info actual-stdout)]	×
198	['original (string-block-info original-stdout)])	×
199	(fail-check "output to stdout changed")))	×
200	(unless (equal? original-stderr actual-stderr)	1✔
201	(with-check-info (['logs (build-logs-info)]	×
202	['actual (string-block-info actual-stderr)]	×
203	['original (string-block-info original-stderr)])	×
204	(fail-check "output to stderr changed"))))))	×
205
206
207	(define-check (check-suite-does-not-refactor original-program)	1✔
208	(define suite (current-suite-under-test))	1✔
209	(set! original-program (code-block-append (current-header) original-program))	1✔
210	(fail-unless-program-compiles original-program)	1✔
211	(define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))	1✔
212	(define result-set	1✔
213	(call-with-logs-captured	1✔
214	(λ ()	1✔
215	(resyntax-analyze (string-source (code-block-raw-string original-program)) #:suite suite))))	1✔
216	(define refactored-program	1✔
217	(modified-source-contents (refactoring-result-set-updated-source result-set)))	1✔
218	(with-check-info* (make-matched-rules-check-info result-set)	1✔
219	(λ ()	1✔
220	(with-check-info (['logs (build-logs-info)]	1✔
221	['actual (string-block-info refactored-program)]	1✔
222	['original (string-block-info (code-block-raw-string original-program))])	1✔
223	(unless (equal? refactored-program (code-block-raw-string original-program))	1✔
224	(fail-check "expected no changes, but changes were made")))	×
225	(with-check-info (['logs (build-logs-info)]	1✔
226	['actual (string-block-info refactored-program)])	1✔
227	(unless (empty? (refactoring-result-set-results result-set))	1✔
228	(fail-check "the program was not changed, but no-op fixes were suggested"))))))	×
229
230
231	(define (fail-unless-program-compiles program)	1✔
232	(define src (string-source (code-block-raw-string program)))	1✔
233	(define expansion-result	1✔
234	(parameterize ([current-namespace (make-base-namespace)])	1✔
235	(result (source-expand src))))	1✔
236	(match expansion-result	1✔
237	[(? success?) (void)]	1✔
NEW 238	[(failure e)	×
NEW 239	(with-check-info (['actual (string-block-info (code-block-raw-string program))]	×
NEW 240	['exception e])	×
NEW 241	(fail-check "the program raised an error when compiled and couldn't be analyzed"))]))	×
242
243
244	(define-check (check-suite-analysis program context-list target property-key expected-value)	1✔
245	(define suite (current-suite-under-test))	1✔
246	(set! program (code-block-append (current-header) program))	1✔
247	(define program-src (string-source (code-block-raw-string program)))	1✔
248	(define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))	1✔
249
250	(define actual-props	1✔
251	(call-with-logs-captured	1✔
252	(λ () (reysntax-analyze-for-properties-only program-src))))	1✔
253
254	(define target-src (string-source (string-trim (code-block-raw-string target))))	1✔
255	(define context-src-list	1✔
256	(for/list ([ctx (in-list context-list)])	1✔
257	(string-source (string-trim (code-block-raw-string ctx)))))	1✔
258
259	(define target-path (source-find-path-of program-src target-src #:contexts context-src-list))	1✔
260
261	(unless target-path	1✔
262	(with-check-info (['logs (build-logs-info)]	×
263	['program (string-block-info (string-source-contents program-src))]	×
264	['target (string-block-info (string-source-contents target-src))])	×
265	(fail-check "could not locate target subform within the given program")))	×
266
267	(define (fail-property-lookup)	1✔
268	(define target-properties	×
269	(syntax-property-bundle-get-immediate-properties actual-props target-path))	×
270	(with-check-info (['logs (build-logs-info)]	×
271	['program (string-block-info (string-source-contents program-src))]	×
272	['target (string-block-info (string-source-contents target-src))]	×
273	['target-path target-path]	×
274	['target-properties target-properties]	×
275	['property-key property-key])	×
276	(fail-check "analysis did not assign a value for the given syntax property key")))	×
277
278	(define actual-value	1✔
279	(syntax-property-bundle-get-property actual-props target-path property-key fail-property-lookup))	1✔
280
281	(unless (equal? actual-value expected-value)	1✔
282	(with-check-info (['logs (build-logs-info)]	×
283	['program (string-block-info (string-source-contents program-src))]	×
284	['target (string-block-info (string-source-contents target-src))]	×
285	['target-path target-path]	×
286	['property-key property-key]	×
287	['actual actual-value]	×
288	['expected expected-value])	×
289	(fail-check "analysis assigned an incorrect value for the given syntax property key"))))	×
290
291
292	(define (source-find-path-of src target-src #:contexts [context-srcs '()])	1✔
293	(define stx (syntax-label-paths (source-read-syntax src) 'source-path))	1✔
294	(define target-as-string (string-source-contents target-src))	1✔
295
296	(define target-stx	1✔
297	(let loop ([stx stx] [context-srcs context-srcs])	1✔
298	(match context-srcs	1✔
299	['()	1✔
300	(syntax-find-first stx subform	1✔
301	#:when (equal? (source-text-of src (attribute subform)) target-as-string))]	1✔
302	[(cons next-context remaining-contexts)	1✔
303	(define next-as-string (string-source-contents next-context))	1✔
304	(define substx	1✔
305	(syntax-find-first stx subform	1✔
306	#:when (equal? (source-text-of src (attribute subform)) next-as-string)))	1✔
307	(and substx (loop substx remaining-contexts))])))	1✔
308
309	(and target-stx (syntax-property target-stx 'source-path)))	1✔
310
311
312	(module+ test
313	(test-case "source-find-path-of"
314
315	(test-case "no #lang"
316	(define src (string-source "(+ a b c)"))
317	(define target (string-source "b"))
318	(check-equal? (source-find-path-of src target) (syntax-path (list 2))))
319
320	(test-case "simple #lang"
321	(define src (string-source "#lang racket (define a 1)"))
322	(define target (string-source "a"))
323	(check-equal? (source-find-path-of src target) (syntax-path (list 3 1 1))))
324
325	(test-case "single context"
326	(define src (string-source "(list (+ a) (* a))"))
327	(define target (string-source "a"))
328	(define contexts (list (string-source "(* a)")))
329	(check-equal? (source-find-path-of src target #:contexts contexts) (syntax-path (list 2 1))))
330
331	(test-case "multiple contexts"
332	(define src (string-source "(+ a (+ a (+ a (+ a))))"))
333	(define target (string-source "a"))
334	(define contexts
335	(list (string-source "(+ a (+ a (+ a)))")
336	(string-source "(+ a (+ a))")
337	(string-source "(+ a)")))
338
339	(define actual-path (source-find-path-of src target #:contexts contexts))
340
341	(check-equal? actual-path (syntax-path (list 2 2 2 1))))))
342
343
344	(define (refactoring-result-set-matched-rules-info result-set)	1✔
345	(define matches	1✔
346	(transduce (refactoring-result-set-results result-set)	1✔
347	(mapping refactoring-result-rule-name)	1✔
348	#:into into-multiset))	1✔
349	(nested-info	1✔
350	(transduce (in-hash-entries (multiset-frequencies matches))	1✔
351	(mapping-values	1✔
352	(λ (match-count)	1✔
353	(string-info (format "~a match~a" match-count (if (= match-count 1) "" "es")))))	×
354	(mapping (λ (e) (check-info (entry-key e) (entry-value e))))	1✔
355	#:into into-list)))	1✔
356
357
358	(define-tuple-type program-output (stdout stderr))	1✔
359
360
361	(define (eval-program program)	1✔
362	(define stdout (open-output-string))	1✔
363	(define stderr (open-output-string))	1✔
364	(parameterize ([current-namespace (make-base-namespace)])	1✔
365	(define (read-from-input)	1✔
366	(port-count-lines! (current-input-port))	1✔
367	(with-module-reading-parameterization read-syntax))	1✔
368	(define stx (with-input-from-string program read-from-input))	1✔
369	(define module-name	1✔
370	(syntax-parse stx #:datum-literals (module) [(module name:id _ ...) (syntax-e #'name)]))	1✔
371	(parameterize ([current-output-port stdout]	1✔
372	[current-error-port stderr])	1✔
373	(eval stx)	1✔
374	(dynamic-require `',module-name #false)))	1✔
375	(program-output	1✔
376	(string->immutable-string (get-output-string stdout))	1✔
377	(string->immutable-string (get-output-string stderr))))	1✔
378
379
380	(module+ test
381	(test-case "eval-program"
382	(check-equal? (eval-program "#lang racket/base (or 1 2 3)") (program-output "1\n" ""))))

jackfirth / resyntax / #78

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous