Guide local repairs for Qt Tetris failures
ober
d7ebe36dbb930ddb4cb791e97421fef990b1bff8
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -1081,6 +1081,7 @@ '(("qt-timer-on-timeout!" . "qt-on-timeout!") ("qt-app-exit!" . "qt-app-quit!") ("qt-widget-grab-to-png!" . "qt-widget-screenshot!") + ("get-environment-variable" . "getenv") ("atom-set!" . "atom-reset!") ("atom-val" . "atom-deref") ("Qt::Key_Left" . "16777234") @@ -1700,28 +1701,91 @@ path start-line end-line start-line 'qt-lifecycle candidate))))))))) +(def (self-test-dispatch-failure? detail) + (and (or (string-contains detail "self-test timed out") + (string-contains detail "self-test command failed") + (string-contains detail + "self-test did not write a non-empty screenshot") + (string-contains detail + "self-test did not print expected OK line")) + (or (string-contains detail "self-test") + (string-contains detail "vector-ref: #f is not a vector")))) + (def (self-test-command-line-repair detail cwd) - (and (string-contains detail "self-test timed out") - (string-contains detail "self-test command failed") + (and (self-test-dispatch-failure? detail) (let ((source (source-containing-symbol cwd "--self-test"))) (and source (let* ((path (car source)) (content (cadr source)) - (old + (old-cond " [(and (= (length args) 1)\n (string=? (car args) \"--self-test\"))") - (index (string-contains content old)) - (candidate - " [(member \"--self-test\" raw-command-line)")) - (and index - (let ((start-line - (line-number-at-index content index)) - (end-line - (line-number-at-index - content - (+ index (string-length old) -1)))) - (make-required-range-repair - path start-line end-line start-line - 'command-line candidate)))))))) + (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* ((start-index + (definition-start-index content "self-test?")) + (end-index + (and start-index + (form-end-index content start-index))) + (definition + (and end-index + (substring content start-index end-index)))) + (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 + "(def self-test?\n (member \"--self-test\" raw-command-line))")))))))))) + +(def (piece-shapes-index-repair detail cwd) + (and (string-contains detail "Exception in vector-ref:") + (string-contains detail "is not a valid index") + (string-contains detail "PIECE-SHAPES") + (let ((source (source-containing-symbol cwd "PIECE-SHAPES"))) + (and source + (let* ((path (car source)) + (content (cadr source)) + (lines (string-split content #\newline)) + (first #f) + (last #f)) + (let loop ((rest lines) (line-no 1)) + (unless (null? rest) + (when (string-contains (car rest) + "(vector-ref PIECE-SHAPES type)") + (unless first (set! first line-no)) + (set! last line-no)) + (loop (cdr rest) (+ line-no 1)))) + (and first last + (let* ((span + (string-join + (take-up-to + (list-tail lines (- first 1)) + (+ (- last first) 1)) + "\n")) + (candidate + (replace-all + span + "(vector-ref PIECE-SHAPES type)" + "(vector-ref PIECE-SHAPES (- type 1))"))) + (and (not (string=? span candidate)) + (make-required-range-repair + path first last first + 'piece-index candidate))))))))) (def (self-test-game-over-repair detail cwd) (and (string-contains detail @@ -1757,11 +1821,13 @@ (qt-lifecycle-repair detail cwd) (self-test-command-line-repair detail cwd) (self-test-game-over-repair detail cwd) + (piece-shapes-index-repair detail cwd) (unexpected-close-repair detail cwd))) (def *failure-source-primitives* '("vector-ref" "vector-set!" + "=" "list-ref" "string-ref" "string-set!" @@ -1810,6 +1876,13 @@ (else (loop (cdr rest) (+ line-no 1) out left))))) +(def (source-targets-contain? targets needle) + (let loop ((xs targets)) + (cond + ((null? xs) #f) + ((string-contains (car xs) needle) #t) + (else (loop (cdr xs)))))) + (def (runtime-primitive-specific-guidance detail primitive) (let ((lower (string-downcase (or detail "")))) (cond @@ -1822,13 +1895,39 @@ "specific `vector-ref` call whose first argument is that list to " "`list-ref`, or convert exactly that data initializer to a valid vector " "of vectors. Do not rewrite the whole constant block unless the one-line " - "accessor repair cannot fit the current data shape.")) + "accessor repair cannot fit the current data shape." + (if (string-contains lower "#f is not a vector") + (string-append + "\nIf the value is `#f` in a Qt self-test and the writable file " + "contains a `self-test?` flag, first verify that `--self-test` is " + "detected by membership in the full raw command line. `jerbuild " + "exec` may pass wrapper arguments before the script flag; do not " + "require `--self-test` to be the first or only parsed argument.") + ""))) + ((and (string=? primitive "vector-ref") + (string-contains lower "is not a valid index") + (string-contains lower "piece-shapes")) + (string-append + "\nTetromino index hint: if active piece ids are 1..7 but " + "`PIECE-SHAPES` has seven vector entries at indexes 0..6, every " + "`(vector-ref PIECE-SHAPES type)` access must use `(- type 1)`, " + "including drawing and locking helpers, not just collision checks.")) ((and (string=? primitive "vector-set!") (string-contains lower "is not a vector")) (string-append "\nThe runtime value passed to `vector-set!` is not mutable vector data. " "Repair the specific container shape first: use vectors for mutable " "grids/rows, or rebuild lists functionally instead of mutating them.")) + ((and (string=? primitive "=") + (string-contains lower "#(0 0 0 0") + (string-contains lower "is not a number")) + (string-append + "\nVector grid corruption hint: a board cell read returned an entire " + "row/grid vector where numeric cell contents were expected. Inspect " + "line-clearing or compaction code for writes such as " + "`(vector-set! board row whole-grid)`. A 10x20 board must stay a " + "vector of 20 row vectors, each row a vector of 10 numbers; never " + "store the whole board/vector-of-rows into one row slot.")) (else "")))) (def (runtime-source-guidance detail cwd) @@ -1840,12 +1939,17 @@ (let* ((lines (string-split (read-file-string absolute) #\newline)) (targets (source-target-lines lines path primitive 6))) (and (pair? targets) - (string-append + (string-append "Source targets for `" primitive "`:\n" (string-join targets "\n") "\nRepair the call site or its argument/index guard with the smallest local edit, then call verify." (runtime-primitive-specific-guidance - detail primitive))))))))) + (if (and (string=? primitive "vector-ref") + (source-targets-contain? + targets "PIECE-SHAPES")) + (string-append detail "\nPIECE-SHAPES") + detail) + primitive))))))))) (def (unbound-symbol-specific-guidance symbol) (cond @@ -3184,7 +3288,7 @@ (def (candidate-required-repair? repair) (member (repair-ref repair 'kind) '(syntax syntax-auto call-arity unbound-symbol runtime-arity - qt-lifecycle command-line self-test-logic))) + qt-lifecycle command-line self-test-logic piece-index))) (def (automatic-required-repair-call) (let* ((repair (current-required-range-repair)) @@ -3193,7 +3297,8 @@ (and candidate (member kind '(syntax-auto call-arity unbound-symbol runtime-arity - qt-lifecycle command-line self-test-logic delimiter)) + qt-lifecycle command-line self-test-logic + piece-index delimiter)) (list (make-wtool-call "replace_range" --- a/test/run.ss +++ b/test/run.ss @@ -3436,6 +3436,45 @@ (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)] + [initial + (string-append + "(import (jerboa prelude))\n" + "(def raw-command-line (command-line))\n" + "(def args (cdr raw-command-line))\n" + "(def self-test? (and (pair? args) (string=? (car args) \"--self-test\")))\n" + "(if self-test? (display \"self\") (display \"interactive\"))\n")] + [responder + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "if grep -q '(car args)' " target + "; then echo 'Exception in vector-ref: #f is not a vector'; 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 self-test flag definition" + (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 self-test flag definition repair verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: self-test flag definition uses raw command 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 "(car args)"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-self-test-game-over-auto-repair.ss"] [target-path (string-append vr-dir "/" target)] [initial @@ -3483,6 +3522,45 @@ "/tmp/jcode-local-self-test-game-over-auto-repair.ss")) (let* ([vr-dir "/tmp"] + [target "jcode-local-piece-shapes-index-auto-repair.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + (string-append + "(import (jerboa prelude))\n" + "(def PIECE-SHAPES (vector 'a 'b 'c 'd 'e 'f 'g))\n" + "(def (piece-valid? type)\n" + " (let ((shape (vector-ref PIECE-SHAPES type))) shape))\n" + "(def (lock-piece! type)\n" + " (let ((shape (vector-ref PIECE-SHAPES type))) shape))\n")] + [responder + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "if grep -q '(vector-ref PIECE-SHAPES type)' " target + "; then echo 'Exception in vector-ref: 7 is not a valid index for #(a b c d e f g)'; 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 one-based piece shape indexes" + (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 piece shape index repairs verify" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: piece shape index repairs every call site" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "(vector-ref PIECE-SHAPES (- type 1))") + (not (str-contains? s "(vector-ref PIECE-SHAPES type)"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-runtime-arity-repair.ss"] [target-path (string-append vr-dir "/" target)] [initial @@ -3607,7 +3685,8 @@ "(defstruct state (next-type))\n" "(set-state-next-type! first 1)\n" "(set-state-next-type! second 2)\n" - "(qt-paint-widget-set-minimum-size! canvas 10 20)\n")] + "(qt-paint-widget-set-minimum-size! canvas 10 20)\n" + "(display (get-environment-variable \"TETRIS_SCREENSHOT\"))\n")] [tool-results '()] [responder (scripted-responder @@ -3622,7 +3701,9 @@ "elif grep -q set-state-next-type " target "; then echo 'Exception: variable set-state-next-type! is not bound'; exit 1; " "elif grep -q qt-paint-widget-set-minimum-size " target - "; then echo 'Exception: variable qt-paint-widget-set-minimum-size! is not bound'; exit 1; fi")]) + "; then echo 'Exception: variable qt-paint-widget-set-minimum-size! is not bound'; exit 1; " + "elif grep -q get-environment-variable " target + "; then echo 'Exception: variable get-environment-variable is not bound'; exit 1; fi")]) (safe-delete-test-file! target-path) (call-with-output-file target-path (lambda (p) (display initial p)) 'replace) @@ -3672,9 +3753,12 @@ (str-contains? s "(state-next-type-set! second 2)") (str-contains? s "(qt-widget-set-minimum-size! canvas 10 20)") + (str-contains? s + "(display (getenv \"TETRIS_SCREENSHOT\"))") (not (str-contains? s "atom-set!")) (not (str-contains? s "atom-val")) - (not (str-contains? s "set-state-next-type!"))))) + (not (str-contains? s "set-state-next-type!")) + (not (str-contains? s "get-environment-variable"))))) (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] @@ -6600,6 +6684,30 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-runtime-vector-as-number-source-target.ss"] + [target-path (string-append vr-dir "/" target)] + [source "(def (board-empty? b r c)\n (= (vector-ref (vector-ref b r) c) 0))\n(def (clear-lines! b new-rows cleared)\n (vector-set! b cleared new-rows))\n"]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display source o)) + 'replace) + (let* ([scope (parse-write-scope target)] + [result (parameterize ((current-write-scope scope)) + (run-verify-command + "sh -c 'echo \"Exception in =: #(0 0 0 0 0 0 ...) is not a number\"; exit 1'" + vr-dir))]) + (check! "verified-run: vector-as-number source target keeps verify failing" + (car result) #f) + (check-pred! "verified-run: vector-as-number guidance points at board corruption" + (cdr result) + (lambda (s) + (and (str-contains? s "Source targets for `=`") + (str-contains? s "Vector grid corruption hint") + (str-contains? s "vector of 20 row vectors") + (str-contains? s "never store the whole board"))))) + (safe-delete-test-file! target-path)) + +(let* ([vr-dir "/tmp"] [target "jcode-verified-unbound-canvas-source-target.ss"] [target-path (string-append vr-dir "/" target)] [source "(import (jerboa prelude))\n(import (jerboa-qt qt))\n(def (handle-key!)\n (qt-paint-widget-update! canvas))\n(with-qt-app app\n (let* ([canvas (qt-paint-widget-create)])\n (qt-on-key-press! canvas (lambda () (handle-key!)))))\n"])