Repair getenv arity guidance
ober
0e07befb7df793ca99d3c6288eb28659d06c062b
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -856,6 +856,56 @@ (make-required-range-repair path line-no line-no line-no 'delimiter candidate))))))))))) +(def (skip-horizontal-space s i) + (let ((n (string-length s))) + (let loop ((j i)) + (if (and (< j n) + (let ((ch (string-ref s j))) + (or (char=? ch #\space) + (char=? ch #\tab)))) + (loop (+ j 1)) + j)))) + +(def (string-literal-end s i) + (let ((n (string-length s))) + (and (< i n) + (char=? (string-ref s i) #\") + (let loop ((j (+ i 1)) (escaped? #f)) + (cond + ((>= j n) #f) + (escaped? (loop (+ j 1) #f)) + ((char=? (string-ref s j) #\\) + (loop (+ j 1) #t)) + ((char=? (string-ref s j) #\") + (+ j 1)) + (else + (loop (+ j 1) #f))))))) + +(def (getenv-two-arg-candidate line) + (let ((idx (and line (string-contains line "(getenv")))) + (and idx + (let* ((after-name (skip-horizontal-space + line + (+ idx (string-length "(getenv")))) + (first-end (string-literal-end line after-name))) + (and first-end + (let* ((second-start (skip-horizontal-space line first-end)) + (second-end (string-literal-end line second-start))) + (and second-end + (let ((close-idx (skip-horizontal-space line second-end))) + (and (< close-idx (string-length line)) + (char=? (string-ref line close-idx) #\)) + (string-append + (substring line 0 idx) + "(or (getenv " + (substring line after-name first-end) + ") " + (substring line second-start second-end) + ")" + (substring line + (+ close-idx 1) + (string-length line)))))))))))) + (def (call-arity-repair detail cwd) (if (not (string-contains detail "incorrect argument count in call")) #f @@ -874,12 +924,15 @@ (line (line-at lines line-no)) (candidate (and line - (string-contains detail - "(random range *random-state*)") - (replace-first - line - "(random range *random-state*)" - "(random range)")))) + (or + (and (string-contains detail + "(random range *random-state*)") + (replace-first + line + "(random range *random-state*)" + "(random range)")) + (and (string-contains line "(getenv") + (getenv-two-arg-candidate line)))))) (make-required-range-repair path line-no line-no line-no 'call-arity candidate)))))))))) @@ -2617,11 +2670,12 @@ (def (required-repair-best-candidate cwd repair) (or (repair-ref repair 'candidate) - (let ((span (repair-span-content cwd repair))) - (and span - (best-repair-candidate - span - (required-repair-label repair)))))) + (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))))))) (def (candidate-required-repair? repair) (member (repair-ref repair 'kind) --- a/test/run.ss +++ b/test/run.ss @@ -4425,6 +4425,57 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-call-arity-getenv-default.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + "(import (jerboa prelude))\n(def (pick-path)\n (let ((path (getenv \"TETRIS_SCREENSHOT\" \"/tmp/kratistos-qt-tetris-selftest.png\")))\n path))\n"] + [tool-results '()] + [responder + (scripted-responder + (list + (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "grep -q '(or (getenv \"TETRIS_SCREENSHOT\") \"/tmp/kratistos-qt-tetris-selftest.png\")' " target + " || { echo 'Exception: incorrect argument count in call (getenv \"TETRIS_SCREENSHOT\" \"/tmp/kratistos-qt-tetris-selftest.png\") at line 3, char 15 of " + target-path + "'; exit 1; }")]) + (safe-delete-test-file! target-path) + (call-with-output-file target-path + (lambda (p) (display initial p)) 'replace) + (let ([result + (verified-run responder "repair a getenv default call" + (list + (cons 'cwd vr-dir) + (cons 'verify-command verify-command) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 6) + (cons 'max-tool-errors 2) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) + (check! "verified-run: getenv call-arity line repair verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: getenv call-arity diagnosis supplies default candidate" + (reverse tool-results) + (lambda (xs) + (let loop ([rest xs]) + (and (pair? rest) + (or (and (str-contains? (car rest) "Call arity diagnosis") + (str-contains? (car rest) + "(or (getenv \"TETRIS_SCREENSHOT\") \"/tmp/kratistos-qt-tetris-selftest.png\")")) + (loop (cdr rest))))))) + (check-pred! "verified-run: getenv call-arity candidate applies automatically" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "(or (getenv \"TETRIS_SCREENSHOT\") \"/tmp/kratistos-qt-tetris-selftest.png\")") + (not (str-contains? s "(getenv \"TETRIS_SCREENSHOT\" \"/tmp/kratistos-qt-tetris-selftest.png\")"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-inspected-draft-cap.ss"] [target-path (string-append vr-dir "/" target)] [bad "(import (jerboa prelude))\n(def (main)\n (displayln \"bad\")))\n"]