Repair invalid with-qt-app bindings
Jaime Fournier <jaimef@linbsd.org>
d720f3563bb9f2f706f1143d72926e3dbbf8f9d9
diff --git a/src/jcode/core/verified-run.ss b/src/jcode/core/verified-run.ss
index a142980..0109fb4 100644
--- a/src/jcode/core/verified-run.ss
+++ b/src/jcode/core/verified-run.ss
@@ -650,6 +650,17 @@
(<= line-no (length lines))
(list-ref lines (- line-no 1))))
+(def (line-start-index-at content line-no)
+ (and (>= line-no 1)
+ (let ((n (string-length content)))
+ (let loop ((i 0) (line 1))
+ (cond
+ ((= line line-no) i)
+ ((>= i n) #f)
+ ((char=? (string-ref content i) #\newline)
+ (loop (+ i 1) (+ line 1)))
+ (else (loop (+ i 1) line)))))))
+
(def (previous-define-line lines line-no)
(let loop ((n (min line-no (length lines))))
(cond
@@ -1300,31 +1311,141 @@
(balance-report candidate "run-self-test"))
candidate)))))))
+(def (line-leading-space line)
+ (let loop ((i 0))
+ (cond
+ ((>= i (string-length line)) line)
+ ((char-whitespace? (string-ref line i)) (loop (+ i 1)))
+ (else (substring line 0 i)))))
+
+(def (qt-invalid-bound-with-app-line? line)
+ (let ((trimmed (string-trim line)))
+ (or (string=? trimmed "[app (with-qt-app (lambda () #t))])")
+ (string=? trimmed "(app (with-qt-app (lambda () #t))))"))))
+
+(def (qt-invalid-bound-let-line? line)
+ (let ((trimmed (string-trim line)))
+ (and (string-prefix? "(let " trimmed)
+ (or (string-contains trimmed "([")
+ (string-contains trimmed "((")))))
+
+(def (qt-close-let-binding-list-line line)
+ (let ((trimmed (string-trim line)))
+ (cond
+ ((string-suffix? "])" trimmed) line)
+ ((string-suffix? "))" trimmed) line)
+ ((or (string-suffix? "]" trimmed)
+ (string-suffix? ")" trimmed))
+ (string-append line ")"))
+ (else #f))))
+
+(def (qt-invalid-bound-with-app-lines-candidate lines)
+ (let loop ((prefix '()) (rest lines))
+ (cond
+ ((or (null? rest) (null? (cdr rest))) #f)
+ ((and (qt-invalid-bound-let-line? (car rest))
+ (qt-invalid-bound-with-app-line? (cadr rest)))
+ (let ((closed-let (qt-close-let-binding-list-line (car rest))))
+ (and closed-let
+ (append
+ (reverse prefix)
+ (list closed-let
+ (string-append
+ (line-leading-space (car rest))
+ " (with-qt-app app"))
+ (cddr rest)))))
+ (else (loop (cons (car rest) prefix) (cdr rest))))))
+
+(def (qt-invalid-bound-with-app-candidate definition label)
+ (and (string-contains definition "(with-qt-app (lambda () #t))")
+ (let ((patched-lines
+ (qt-invalid-bound-with-app-lines-candidate
+ (string-split definition #\newline))))
+ (and patched-lines
+ (let ((candidate
+ (string-append
+ (string-join patched-lines "\n")
+ ")")))
+ (and (balance-ok-text?
+ (balance-report candidate label))
+ candidate))))))
+
+(def (qt-invalid-bound-with-app-repair detail cwd)
+ (and (string-contains detail "invalid bound variable")
+ (string-contains detail "(lambda () #t)")
+ (let* ((diag-start
+ (or (find-diagnostic-start detail
+ (list "invalid bound variable"))
+ 0))
+ (line-no
+ (find-line-number-after-from detail " at line " diag-start)))
+ (and line-no
+ (let ((path (verification-source-path cwd detail line-no diag-start)))
+ (and path
+ (let ((p (abs-path cwd path)))
+ (and (file-exists? p)
+ (let* ((content (read-file-string p))
+ (lines (string-split content #\newline))
+ (start-line
+ (previous-top-level-define-line
+ lines line-no))
+ (start-index
+ (and start-line
+ (line-start-index-at
+ content start-line)))
+ (end-index
+ (and start-index
+ (form-end-index
+ content start-index)))
+ (definition
+ (and end-index
+ (substring
+ content start-index end-index)))
+ (end-line
+ (and end-index
+ (line-number-at-index
+ content
+ (max start-index
+ (- end-index 1)))))
+ (label
+ (and start-line end-line
+ (format "~a lines ~a-~a"
+ path start-line end-line)))
+ (candidate
+ (and definition label
+ (qt-invalid-bound-with-app-candidate
+ definition label))))
+ (and candidate
+ (make-required-range-repair
+ path start-line end-line line-no
+ 'qt-lifecycle candidate)))))))))))
+
(def (qt-lifecycle-repair detail cwd)
- (and (string-contains detail "missing with-qt-app")
- (or (string-contains detail "self-test timed out")
- (string-contains detail "self-test command failed")
- (string-contains detail "self-test did not print expected OK line")
- (string-contains detail
- "self-test did not write a non-empty screenshot"))
- (let ((source (source-containing-symbol cwd "qt-app-create")))
- (and source
- (let* ((path (car source))
- (content (cadr source))
- (start-index
- (definition-start-index content "run-self-test"))
- (end-index
- (and start-index (form-end-index content start-index)))
- (candidate (qt-self-test-lifecycle-candidate content)))
- (and candidate end-index
- (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
- 'qt-lifecycle candidate))))))))
+ (or (qt-invalid-bound-with-app-repair detail cwd)
+ (and (string-contains detail "missing with-qt-app")
+ (or (string-contains detail "self-test timed out")
+ (string-contains detail "self-test command failed")
+ (string-contains detail "self-test did not print expected OK line")
+ (string-contains detail
+ "self-test did not write a non-empty screenshot"))
+ (let ((source (source-containing-symbol cwd "qt-app-create")))
+ (and source
+ (let* ((path (car source))
+ (content (cadr source))
+ (start-index
+ (definition-start-index content "run-self-test"))
+ (end-index
+ (and start-index (form-end-index content start-index)))
+ (candidate (qt-self-test-lifecycle-candidate content)))
+ (and candidate end-index
+ (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
+ 'qt-lifecycle candidate)))))))))
(def (self-test-command-line-repair detail cwd)
(and (string-contains detail "self-test timed out")
diff --git a/test/run.ss b/test/run.ss
index ed70d9f..0c140bb 100644
--- a/test/run.ss
+++ b/test/run.ss
@@ -3230,14 +3230,60 @@
(cons 'max-tool-errors 2)))])
(check! "verified-run: automatic Qt lifecycle repair verifies"
result "VERIFIED: exit 0\n"))
- (check-pred! "verified-run: Qt lifecycle repair targets only self-test"
+ (check-pred! "verified-run: Qt lifecycle repair targets only self-test"
+ (call-with-input-file target-path (lambda (p) (get-string-all p)))
+ (lambda (s)
+ (and (str-contains? s "(with-qt-app app")
+ (str-contains? s "(let* (")
+ (not (str-contains? s "qt-app-create"))
+ (not (str-contains? s "qt-app-destroy!"))
+ (not (str-contains? s "qt-app-quit!")))))
+ (safe-delete-test-file! target-path))
+
+ (let* ([vr-dir "/tmp"]
+ [target "jcode-local-qt-invalid-bound-with-app-auto-repair.ss"]
+ [target-path (string-append vr-dir "/" target)]
+ [initial
+ (string-append
+ "(import (jerboa prelude))\n"
+ "(def (main args)\n"
+ " (let ([self-test? #t])\n"
+ " (let ([gs (make-game-state)]\n"
+ " [app (with-qt-app (lambda () #t))])\n"
+ " (qt-pump-events! app)\n"
+ " (display gs))))\n"
+ "(main '())\n")]
+ [responder
+ (scripted-responder
+ (list (list (make-wtool-call "verify" '() #f))))]
+ [verify-command
+ (string-append
+ "if grep -q '(with-qt-app (lambda () #t))' " target
+ "; then echo 'Exception: invalid bound variable (lambda () #t) in broken form at line 5, char 16 of "
+ target-path
+ "'; exit 2; fi; "
+ "grep -q '(with-qt-app app' " target
+ " || { echo 'FAIL: repair missing with-qt-app app'; 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 invalid bound with-qt-app use"
+ (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)))])
+ (check! "verified-run: invalid bound with-qt-app auto repair verifies"
+ result "VERIFIED: exit 0\n"))
+ (check-pred! "verified-run: invalid bound with-qt-app wraps existing body only"
(call-with-input-file target-path (lambda (p) (get-string-all p)))
(lambda (s)
(and (str-contains? s "(with-qt-app app")
- (str-contains? s "(let* (")
- (not (str-contains? s "qt-app-create"))
- (not (str-contains? s "qt-app-destroy!"))
- (not (str-contains? s "qt-app-quit!")))))
+ (str-contains? s "(main '())")
+ (not (str-contains? s "(with-qt-app (lambda () #t))")))))
(safe-delete-test-file! target-path))
(let* ([vr-dir "/tmp"]