Repair parenthesized self-test dispatch
ober
a488fa104a9fe9cc33b4d61ead144d86de35a8f5
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -1717,49 +1717,71 @@ (and source (let* ((path (car source)) (content (cadr source)) - (old-cond - " [(and (= (length args) 1)\n (string=? (car args) \"--self-test\"))") - (cond-index (string-contains content old-cond))) - (if cond-index - (let ((start-line - (line-number-at-index content cond-index)) - (end-line - (line-number-at-index - content - (+ cond-index (string-length old-cond) -1)))) - (make-required-range-repair - path start-line end-line start-line - 'command-line - " [(member \"--self-test\" raw-command-line)")) - (let loop ((names '("self-test?" "self-test-mode?" - "self-test-mode"))) - (if (null? names) - #f - (let* ((name (car names)) - (start-index - (definition-start-index content name)) - (end-index - (and start-index - (form-end-index content start-index))) - (definition - (and end-index - (substring content start-index end-index)))) - (if (and definition - (string-contains definition "--self-test") - (not (string-contains definition "member"))) - (let ((start-line - (line-number-at-index content start-index)) - (end-line - (line-number-at-index - content - (max start-index (- end-index 1))))) - (make-required-range-repair - path start-line end-line start-line - 'command-line - (format - "(def ~a\n (member \"--self-test\" raw-command-line))" - name))) - (loop (cdr names)))))))))))) + (cond-patterns + (list + (cons + " [(and (= (length args) 1)\n (string=? (car args) \"--self-test\"))" + " [(member \"--self-test\" raw-command-line)") + (cons + " ((and (= (length args) 1)\n (string=? (car args) \"--self-test\"))" + " ((member \"--self-test\" raw-command-line)") + (cons + " ((and (= (length args) 1) (string=? (car args) \"--self-test\"))" + " ((member \"--self-test\" raw-command-line)")))) + (or + (let loop-cond ((patterns cond-patterns)) + (and (pair? patterns) + (let* ((pattern (car patterns)) + (old-cond (car pattern)) + (new-cond (cdr pattern)) + (cond-index + (string-contains content old-cond))) + (if cond-index + (let ((start-line + (line-number-at-index + content cond-index)) + (end-line + (line-number-at-index + content + (+ cond-index + (string-length old-cond) -1)))) + (make-required-range-repair + path start-line end-line start-line + 'command-line + new-cond)) + (loop-cond (cdr patterns)))))) + (let loop-name ((names '("self-test?" "self-test-mode?" + "self-test-mode"))) + (and (pair? names) + (let* ((name (car names)) + (start-index + (definition-start-index content name)) + (end-index + (and start-index + (form-end-index content start-index))) + (definition + (and end-index + (substring content start-index + end-index)))) + (if (and definition + (string-contains definition "--self-test") + (not + (string-contains definition "member"))) + (let ((start-line + (line-number-at-index + content start-index)) + (end-line + (line-number-at-index + content + (max start-index + (- end-index 1))))) + (make-required-range-repair + path start-line end-line start-line + 'command-line + (format + "(def ~a\n (member \"--self-test\" raw-command-line))" + name))) + (loop-name (cdr names)))))))))))) (def (piece-shapes-index-repair detail cwd) (and (string-contains detail "Exception in vector-ref:") --- a/test/run.ss +++ b/test/run.ss @@ -3435,6 +3435,54 @@ (not (str-contains? s "(length args)"))))) (safe-delete-test-file! target-path)) + (let* ([vr-dir "/tmp"] + [target "jcode-local-self-test-paren-cond-auto-repair.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + (string-append + "(import (jerboa prelude))\n" + "(def raw-command-line (command-line))\n" + "(def args\n" + " (let ((xs (cdr raw-command-line)))\n" + " (if (and (pair? xs)\n" + " (string? (car xs))\n" + " (string-suffix? \".ss\" (car xs)))\n" + " (cdr xs)\n" + " xs)))\n" + "(def (run-self-test) (display \"self\"))\n" + "(cond\n" + " ((and (= (length args) 1) (string=? (car args) \"--self-test\"))\n" + " (run-self-test))\n" + " (else (display \"interactive\")))\n")] + [responder + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "if grep -q 'length args' " target + "; then echo 'FAIL: self-test command failed'; echo 'self-test timed out after 20s'; echo 'FAIL: self-test did not write a non-empty screenshot'; exit 1; fi")]) + (safe-delete-test-file! target-path) + (call-with-output-file target-path + (lambda (p) (display initial p)) 'replace) + (let ([result + (verified-run responder "repair parenthesized self-test cond dispatch" + (list + (cons 'cwd vr-dir) + (cons 'verify-command verify-command) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 5) + (cons 'max-tool-errors 2)))]) + (check! "verified-run: automatic parenthesized self-test dispatch repair verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: parenthesized self-test dispatch uses raw membership" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s + "((member \"--self-test\" raw-command-line)") + (not (str-contains? s "(length args)"))))) + (safe-delete-test-file! target-path)) + (let* ([vr-dir "/tmp"] [target "jcode-local-self-test-flag-def-auto-repair.ss"] [target-path (string-append vr-dir "/" target)]