Diagnose Qt paint widget arity failures
ober
1fa7a4e6de3d7238acb3abbfe9f33f4ea0050a23
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -839,20 +839,25 @@ (or (defstruct-setter-name symbol) (qt-inherited-widget-name symbol))) +(def (source-file-containing-symbol cwd path symbol) + (and (source-ss-path? path) + (file-exists? (abs-path cwd path)) + (not (file-directory? (abs-path cwd path))) + (let* ((content (read-file-string (abs-path cwd path))) + (index (string-contains content symbol))) + (and index (list path content index))))) + (def (source-containing-symbol cwd symbol) + (let ((preferred (scope-primary-file (current-write-scope)))) + (or (and preferred + (source-file-containing-symbol cwd preferred symbol)) + (and (not preferred) (let loop ((entries (directory-list cwd))) (cond ((null? entries) #f) - ((and (source-ss-path? (car entries)) - (file-exists? (abs-path cwd (car entries))) - (not (file-directory? (abs-path cwd (car entries))))) - (let* ((path (car entries)) - (content (read-file-string (abs-path cwd path))) - (index (string-contains content symbol))) - (if index - (list path content index) - (loop (cdr entries))))) - (else (loop (cdr entries)))))) + ((source-file-containing-symbol cwd (car entries) symbol) + => (lambda (source) source)) + (else (loop (cdr entries))))))))) (def (unbound-symbol-repair detail cwd) (let* ((symbol (unbound-variable-name detail)) @@ -900,13 +905,14 @@ (let ((preferred (scope-primary-file (current-write-scope)))) (or (and preferred (source-racket-style-iteration-match cwd preferred symbol)) + (and (not preferred) (let loop ((entries (directory-list cwd))) (cond ((null? entries) #f) (else (or (source-racket-style-iteration-match cwd (car entries) symbol) - (loop (cdr entries))))))))) + (loop (cdr entries)))))))))) (def (unsupported-iteration-diagnosis detail cwd) (let ((symbol (unbound-variable-name detail))) @@ -949,7 +955,14 @@ ((char=? (string-ref content i) #\newline) i) (else (loop (+ i 1)))))) -(def (runtime-arity-match path content symbol) +(def (line-start-index-from content start) + (let loop ((i start)) + (cond + ((<= i 0) 0) + ((char=? (string-ref content (- i 1)) #\newline) i) + (else (loop (- i 1)))))) + +(def (runtime-arity-match path content symbol min-form-length) (let call-loop ((from 0)) (let ((index (find-substring-from content symbol from))) (cond @@ -963,19 +976,21 @@ (read-first-form (substring content start end)))) (len (and form (proper-list-length form)))) - (if (and len (> len 5)) + (if (and len (>= len min-form-length)) (list path content index) (call-loop (+ index (string-length symbol)))))))))) -(def (runtime-arity-source cwd symbol) +(def (runtime-arity-source cwd symbol min-form-length) (let* ((preferred (scope-primary-file (current-write-scope))) (preferred-path (and preferred (abs-path cwd preferred))) (preferred-match (and preferred-path (file-exists? preferred-path) (runtime-arity-match - preferred (read-file-string preferred-path) symbol)))) + preferred (read-file-string preferred-path) + symbol min-form-length)))) (or preferred-match + (and (not preferred) (let file-loop ((entries (directory-list cwd))) (cond ((null? entries) #f) @@ -985,16 +1000,93 @@ (not (file-directory? (abs-path cwd (car entries))))) (let* ((path (car entries)) (content (read-file-string (abs-path cwd path))) - (match (runtime-arity-match path content symbol))) + (match (runtime-arity-match + path content symbol min-form-length))) (or match (file-loop (cdr entries))))) - (else (file-loop (cdr entries)))))))) + (else (file-loop (cdr entries))))))))) + +(def (qt-paint-widget-create-arity-match path content) + (let call-loop ((from 0)) + (let ((start (find-substring-from content "(qt-paint-widget-create" from))) + (and start + (let* ((end (form-end-index content start)) + (form (and end + (read-first-form + (substring content start end)))) + (len (and form (proper-list-length form)))) + (if (and len (> len 2)) + (list path content (+ start 1)) + (call-loop (+ start 1)))))))) + +(def (qt-paint-widget-create-arity-source cwd) + (let* ((preferred (scope-primary-file (current-write-scope))) + (preferred-path (and preferred (abs-path cwd preferred))) + (preferred-match + (and preferred-path + (file-exists? preferred-path) + (qt-paint-widget-create-arity-match + preferred (read-file-string preferred-path))))) + (or preferred-match + (and (not preferred) + (let file-loop ((entries (directory-list cwd))) + (cond + ((null? entries) #f) + ((and (not (and preferred (string=? preferred (car entries)))) + (source-ss-path? (car entries)) + (file-exists? (abs-path cwd (car entries))) + (not (file-directory? (abs-path cwd (car entries))))) + (let* ((path (car entries)) + (content (read-file-string (abs-path cwd path))) + (match (qt-paint-widget-create-arity-match path content))) + (or match (file-loop (cdr entries))))) + (else (file-loop (cdr entries))))))))) + +(def (runtime-arity-min-form-length symbol) + (cond + ((equal? symbol "qt-painter-draw-text!") 6) + ((equal? symbol "qt-paint-widget-create") 3) + (else #f))) + +(def (runtime-arity-candidate symbol form content start end) + (cond + ((equal? symbol "qt-painter-draw-text!") + (and (pair? form) + (>= (length form) 5) + (string-append + (form->string (take-up-to form 5)) + (substring content end + (line-end-index-from content end))))) + ((equal? symbol "qt-paint-widget-create") + (let ((line-start (line-start-index-from content start)) + (line-end (line-end-index-from content end))) + (string-append + (substring content line-start start) + "(qt-paint-widget-create)" + (substring content end line-end)))) + (else #f))) (def (runtime-call-arity-repair detail cwd) - (let* ((symbol (and (string-contains detail - "incorrect number of arguments") + (let* ((arity-detail? + (string-contains detail "incorrect number of arguments")) + (qt-paint-widget-arity-detail? + (and arity-detail? + (string-contains detail "qt-paint-widget-create"))) + (symbol (and arity-detail? (runtime-procedure-name detail))) - (source (and (equal? symbol "qt-painter-draw-text!") - (runtime-arity-source cwd symbol)))) + (effective-symbol + (if qt-paint-widget-arity-detail? + "qt-paint-widget-create" + symbol)) + (min-form-length + (and effective-symbol + (runtime-arity-min-form-length effective-symbol))) + (source (cond + (qt-paint-widget-arity-detail? + (qt-paint-widget-create-arity-source cwd)) + (min-form-length + (runtime-arity-source + cwd effective-symbol min-form-length)) + (else #f)))) (and source (let* ((path (car source)) (content (cadr source)) @@ -1007,12 +1099,9 @@ (read-first-form (substring content start end)))) (candidate - (and (pair? form) - (>= (length form) 5) - (string-append - (form->string (take-up-to form 5)) - (substring content end - (line-end-index-from content end)))))) + (and form + (runtime-arity-candidate + effective-symbol form content start end)))) (and candidate (let ((start-line (line-number-at-index content start)) (end-line @@ -1376,9 +1465,13 @@ (and repair (let ((label (required-repair-label repair))) (string-append - (format - "\n\nRuntime call arity diagnosis: `qt-painter-draw-text!` accepts painter, x, y, and text. Repair the exact multiline call at ~a by removing trailing color arguments, then call verify; remaining occurrences will be diagnosed on subsequent passes." - label) + (if (string-contains detail "qt-paint-widget-create") + (format + "\n\nRuntime call arity diagnosis: `qt-paint-widget-create` accepts zero arguments or one parent widget; it does not accept width/height. Repair the exact call at ~a by using `(qt-paint-widget-create)`, then size the widget separately with `qt-widget-set-fixed-size!` or `qt-widget-resize!` if needed. Then call verify." + label) + (format + "\n\nRuntime call arity diagnosis: `qt-painter-draw-text!` accepts painter, x, y, and text. Repair the exact multiline call at ~a by removing trailing color arguments, then call verify; remaining occurrences will be diagnosed on subsequent passes." + label)) (best-repair-candidate-text cwd repair label)))))) (def (qt-lifecycle-diagnosis detail cwd) --- a/test/run.ss +++ b/test/run.ss @@ -3260,11 +3260,11 @@ (cons 'local-model? #t) (cons 'max-iterations 6) (cons 'max-tool-errors 3) - (cons 'on-message - (lambda (m) - (when (equal? (message-role m) "tool") - (set! tool-results - (cons (message-content m) tool-results)))))))]) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) (check! "verified-run: automatic runtime arity repairs verify" result "VERIFIED: exit 0\n")) (check-pred! "verified-run: runtime arity diagnosis supplies four-argument call" @@ -3286,6 +3286,63 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-local-qt-paint-widget-arity-repair.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + (string-append + "(import (jerboa prelude) (jerboa-qt qt))\n" + "(def *win-w* 320)\n" + "(def *win-h* 480)\n" + "(def (build)\n" + " (let ((canvas (qt-paint-widget-create *win-w* *win-h*)))\n" + " canvas))\n")] + [tool-results '()] + [responder + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "if grep -Fq '(qt-paint-widget-create *win-w* *win-h*)' " target + "; then echo 'Exception: incorrect number of arguments 2 to #<procedure qt-paint-widget-create at fake>'; 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 qt paint widget runtime arity" + (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 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) + (check! "verified-run: automatic Qt paint-widget arity repairs verify" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: Qt paint-widget arity diagnosis supplies zero-arg call" + (reverse tool-results) + (lambda (xs) + (let loop ([rest xs]) + (and (pair? rest) + (or (and (str-contains? (car rest) + "Runtime call arity diagnosis") + (str-contains? (car rest) + "`qt-paint-widget-create` accepts zero arguments") + (str-contains? (car rest) + "(qt-paint-widget-create)")) + (loop (cdr rest))))))) + (check-pred! "verified-run: Qt paint-widget arity candidate applies" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "(qt-paint-widget-create)") + (not (str-contains? s "(qt-paint-widget-create *win-w* *win-h*)"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-unbound-setter-repair.ss"] [target-path (string-append vr-dir "/" target)] [initial