Validate verifier repair candidates
ober
c4422a3833ab5bd54fd1d57a89115731ac66c16a
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -792,14 +792,28 @@ (let ((p (abs-path cwd path))) (if (not (file-exists? p)) #f - (let* ((lines (string-split (read-file-string p) #\newline)) - (start (or (previous-top-level-define-line lines line-no) - line-no)) - (next (next-top-level-define-line lines start)) - (end (if next - (- next 1) - (length lines)))) - (make-required-range-repair path start end line-no 'syntax)))))))))) + (let* ((lines (string-split (read-file-string p) #\newline)) + (start (or (previous-top-level-define-line lines line-no) + line-no)) + (next (next-top-level-define-line lines start)) + (end (if next + (- next 1) + (length lines))) + (span (slice-content + (read-file-string p) + (list (cons "path" path) + (cons "start" start) + (cons "end" end)))) + (label (format "~a lines ~a-~a" path start end)) + (candidate + (and (string-contains detail "invalid syntax #(") + span + (quote-leading-vector-literals-candidate + span label)))) + (make-required-range-repair + path start end line-no + (if candidate 'syntax-auto 'syntax) + candidate)))))))))) (def (no-expressions-repair detail cwd) (and (string-contains detail "no expressions in body") @@ -1308,9 +1322,37 @@ (and (not (string-contains candidate "qt-app-create")) (not (string-contains candidate "qt-app-destroy!")) (balance-ok-text? - (balance-report candidate "run-self-test")) + (balance-report candidate "run-self-test")) candidate))))))) +(def (quote-leading-vector-literal-line line) + (let* ((trimmed (string-trim line)) + (indent (line-leading-space line))) + (and (string-prefix? "#(" trimmed) + (not (string-prefix? "'#(" trimmed)) + (string-append + indent + "'" + (substring line + (string-length indent) + (string-length line)))))) + +(def (quote-leading-vector-literals-candidate content label) + (let loop ((lines (string-split content #\newline)) + (out '()) + (changed? #f)) + (cond + ((null? lines) + (and changed? + (let ((candidate (string-join (reverse out) "\n"))) + (and (balance-ok-text? (balance-report candidate label)) + candidate)))) + (else + (let ((patched (quote-leading-vector-literal-line (car lines)))) + (loop (cdr lines) + (cons (or patched (car lines)) out) + (or changed? patched))))))) + (def (line-leading-space line) (let loop ((i 0)) (cond @@ -2788,28 +2830,54 @@ (repair-ref repair 'start) (repair-ref repair 'end))) +(def (repair-candidate-full-content cwd repair candidate) + (let* ((path (repair-ref repair 'path)) + (p (abs-path cwd path))) + (and (file-exists? p) + (replace-line-range-content + (read-file-string p) + (repair-ref repair 'start) + (repair-ref repair 'end) + candidate)))) + +(def (repair-candidate-applicable? cwd repair candidate) + (let ((path (repair-ref repair 'path))) + (or (not (source-ss-path? path)) + (let ((full-content + (repair-candidate-full-content cwd repair candidate))) + (and full-content + (not (jerboa-syntax-guard-message path full-content))))))) + (def (required-repair-best-candidate cwd repair) - (or (repair-ref repair 'candidate) + (or (let ((candidate (repair-ref repair 'candidate))) + (and candidate + (repair-candidate-applicable? cwd repair candidate) + candidate)) (and (not (eq? (repair-ref repair 'kind) 'call-arity)) (let ((span (repair-span-content cwd repair))) (and span - (best-repair-candidate - span - (required-repair-label repair))))))) + (let ((label (required-repair-label repair))) + (or (syntax-repair-candidate span label) + (let ((candidate + (minimal-balance-candidate span label))) + (and candidate + (repair-candidate-applicable? + cwd repair candidate) + candidate))))))))) (def (candidate-required-repair? repair) (member (repair-ref repair 'kind) - '(syntax call-arity unbound-symbol runtime-arity qt-lifecycle command-line - self-test-logic))) + '(syntax syntax-auto call-arity unbound-symbol runtime-arity + qt-lifecycle command-line self-test-logic))) (def (automatic-required-repair-call) (let* ((repair (current-required-range-repair)) (kind (and repair (repair-ref repair 'kind))) (candidate (and repair (repair-ref repair 'candidate)))) (and candidate - (member kind - '(call-arity unbound-symbol runtime-arity qt-lifecycle command-line - self-test-logic delimiter)) + (member kind + '(syntax-auto call-arity unbound-symbol runtime-arity + qt-lifecycle command-line self-test-logic delimiter)) (list (make-wtool-call "replace_range" @@ -4271,11 +4339,13 @@ (let ((span (repair-span-content cwd repair))) (if (not span) "" - (let ((candidate (minimal-balance-candidate span label))) - (if (and candidate (<= (string-length candidate) 3000)) - (string-append - "\n\nMinimal balanced candidate for replace_range content. Copy this exact span; do not rewrite the whole file:\n" - candidate + (let ((candidate (minimal-balance-candidate span label))) + (if (and candidate + (repair-candidate-applicable? cwd repair candidate) + (<= (string-length candidate) 3000)) + (string-append + "\n\nMinimal balanced candidate for replace_range content. Copy this exact span; do not rewrite the whole file:\n" + candidate "\n\nThen call verify.") ""))))) --- a/test/run.ss +++ b/test/run.ss @@ -6737,6 +6737,31 @@ (str-contains? s "\n)\n\nThen call verify."))))) (safe-delete-test-file! target-path)) + (let* ([vr-dir "/tmp"] + [target "jcode-invalid-context-suppresses-bad-fullfile-candidate.ss"] + [target-path (string-append vr-dir "/" target)] + [bad-source "(import (jerboa prelude))\n(define (bad)\n (displayln \"open\")\n\n(define (next) 2)\n)\n"]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display bad-source o)) + 'replace) + (let* ([cmd (string-append + "printf '%s\\n' 'Exception: invalid context for definition (define (next) 2) at line 5, char 1 of " + target + "' >&2; exit 255")] + [result (run-verify-command cmd vr-dir)] + [detail (cdr result)]) + (check! "verified-run: invalid context paired close fake verify fails" + (car result) #f) + (check-pred! "verified-run: invalid context suppresses candidate that breaks full file" + detail + (lambda (s) + (and (str-contains? s "Structural diagnosis") + (str-contains? s "replace_range") + (not (str-contains? s "Minimal balanced candidate")) + (not (str-contains? s "Concrete corrected candidate")))))) + (safe-delete-test-file! target-path)) + (let* ([vr-dir "/tmp"] [target "jcode-invalid-internal-context-diagnosis.ss"] [target-path (string-append vr-dir "/" target)] @@ -6891,11 +6916,53 @@ (and (str-contains? s "Suspect span") (str-contains? s "(define (bad row)") (str-contains? s "(displayln x)"))))) - (safe-delete-test-file! target-path)) - - (let* ([vr-dir "/tmp"] - [target "jcode-invalid-defstruct-diagnosis.ss"] - [target-path (string-append vr-dir "/" target)] + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] + [target "jcode-invalid-vector-literal-auto-repair.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + (string-append + "(import (jerboa prelude))\n" + "(def SHAPES\n" + " (vector\n" + " ;; T\n" + " #(#(0 1 0) #(1 1 1) #(0 0 0))))\n" + "(display \"ok\")\n")] + [verify-cmd + (string-append + "if grep -q '^ #(' " target + "; then printf '%s\\n' 'Exception: invalid syntax #(#(0 1 0) #(1 1 1) #(0 0 0)) at line 5, char 5 of " + target + "' >&2; exit 255; fi")] + [resp + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display initial o)) + 'replace) + (let ([result + (verified-run resp "auto repair invalid nested vector literal" + (list + (cons 'cwd vr-dir) + (cons 'verify-command verify-cmd) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 6) + (cons 'max-tool-errors 2)))]) + (check! "verified-run: invalid nested vector literal auto repair verifies" + result "VERIFIED: exit 0\n") + (check-pred! "verified-run: invalid nested vector literal quotes data rows" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "'#(#(0 1 0)") + (not (str-contains? s "\n #(#")))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] + [target "jcode-invalid-defstruct-diagnosis.ss"] + [target-path (string-append vr-dir "/" target)] [bad-source "(import (jerboa prelude))\n(defstruct game\n board\n score)\n\n(define (next) 2)\n"]) (safe-delete-test-file! target-path) (write-test-output-file target-path