Repair Qt API alias paper cuts
ober
3e384147bfb05fa63f294bd82950f2ad540aa376
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -1027,9 +1027,26 @@ (string-length prefix) (string-length symbol)))))) +(def qt-api-symbol-aliases + '(("qt-timer-on-timeout!" . "qt-on-timeout!") + ("qt-app-exit!" . "qt-app-quit!") + ("qt-widget-grab-to-png!" . "qt-widget-screenshot!") + ("Qt::Key_Left" . "16777234") + ("Qt::Key_Up" . "16777235") + ("Qt::Key_Right" . "16777236") + ("Qt::Key_Down" . "16777237") + ("Qt::Key_Escape" . "16777216") + ("Qt::Key_Space" . "32") + ("<<" . "bitwise-arithmetic-shift"))) + +(def (qt-api-symbol-alias symbol) + (let ((hit (assoc symbol qt-api-symbol-aliases))) + (and hit (cdr hit)))) + (def (unbound-symbol-replacement symbol) (or (defstruct-setter-name symbol) - (qt-inherited-widget-name symbol))) + (qt-inherited-widget-name symbol) + (qt-api-symbol-alias symbol))) (def (source-file-containing-symbol cwd path symbol) (and (source-ss-path? path) @@ -5178,6 +5195,58 @@ (cons (substring content start (+ idx old-len)) acc) changed?))))))) +(def (replace-string-occurrences content old-str new-str) + (let ((old-len (string-length old-str))) + (and (> old-len 0) + (let loop ((start 0) (acc '()) (changed? #f)) + (let ((idx (find-substring-from content old-str start))) + (cond + ((not idx) + (and changed? + (apply string-append + (reverse + (cons (substring content start + (string-length content)) + acc))))) + (else + (loop (+ idx old-len) + (cons new-str + (cons (substring content start idx) acc)) + #t)))))))) + +(def (apply-symbol-aliases content aliases) + (let loop ((rest aliases) (current content) (changed? #f)) + (cond + ((null? rest) (and changed? current)) + (else + (let* ((alias (car rest)) + (next (replace-symbol-occurrences current + (car alias) + (cdr alias)))) + (if next + (loop (cdr rest) next #t) + (loop (cdr rest) current changed?))))))) + +(def qt-api-expression-aliases + '(("(string->integer \"P\")" . "80") + ("(string->integer \"Q\")" . "81") + ("(string->integer \"p\")" . "80") + ("(string->integer \"q\")" . "81") + ("(>> s 17)" . "(bitwise-arithmetic-shift s -17)"))) + +(def (apply-string-aliases content aliases) + (let loop ((rest aliases) (current content) (changed? #f)) + (cond + ((null? rest) (and changed? current)) + (else + (let* ((alias (car rest)) + (next (replace-string-occurrences current + (car alias) + (cdr alias)))) + (if next + (loop (cdr rest) next #t) + (loop (cdr rest) current changed?))))))) + (def (replace-line content line-no new-line) (let loop ((lines (string-split content #\newline)) (i 1) @@ -5375,12 +5444,25 @@ (def (auto-compat-full-ss-content path content) (and (source-ss-path? path) - (string-contains content "arithmetic-shift") - (let ((candidate - (replace-symbol-occurrences content - "arithmetic-shift" - "bitwise-arithmetic-shift"))) + (let* ((after-arithmetic + (or (and (string-contains content "arithmetic-shift") + (replace-symbol-occurrences content + "arithmetic-shift" + "bitwise-arithmetic-shift")) + content)) + (after-qt-symbols + (or (apply-symbol-aliases after-arithmetic + qt-api-symbol-aliases) + after-arithmetic)) + (after-expressions + (or (apply-string-aliases after-qt-symbols + qt-api-expression-aliases) + after-qt-symbols)) + (candidate + (and (not (string=? content after-expressions)) + after-expressions))) (and candidate + (not (string=? content candidate)) (not (jerboa-syntax-guard-message path candidate)) candidate)))) @@ -5404,9 +5486,15 @@ (string-append (if (and final-content (not (string=? original-content final-content)) - (string-contains original-content "arithmetic-shift") - (string-contains final-content "bitwise-arithmetic-shift")) - " after applying Jerboa compatibility alias repair" + (or (string-contains original-content "arithmetic-shift") + (string-contains original-content "qt-timer-on-timeout!") + (string-contains original-content "qt-app-exit!") + (string-contains original-content "qt-widget-grab-to-png!") + (string-contains original-content "Qt::Key_") + (string-contains original-content "string->integer") + (string-contains original-content "<<") + (string-contains original-content ">>"))) + " after applying Jerboa compatibility alias repair (including Qt aliases)" (auto-balance-repair-message path original-content)))) (def (jerboa-syntax-guard-message path content) --- a/test/run.ss +++ b/test/run.ss @@ -8245,6 +8245,86 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-qt-api-aliases.ss"] + [target-path (string-append vr-dir "/" target)] + [bad + (string-append + "(import (jerboa prelude))\n" + "(def (main app timer canvas key s)\n" + " (qt-timer-on-timeout! timer (lambda () #t))\n" + " (qt-widget-grab-to-png! canvas \"/tmp/out.png\")\n" + " (when (= key Qt::Key_Left) #t)\n" + " (when (= key Qt::Key_Right) #t)\n" + " (when (= key Qt::Key_Down) #t)\n" + " (when (= key Qt::Key_Up) #t)\n" + " (when (= key Qt::Key_Space) #t)\n" + " (when (= key Qt::Key_Escape) (qt-app-exit! app))\n" + " (when (= key (string->integer \"P\")) #t)\n" + " (when (= key (string->integer \"Q\")) #t)\n" + " (list (<< s 13) (>> s 17)))\n")] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (safe-delete-test-file! target-path) + (let* ([scope (parse-write-scope target)] + [tool-results '()] + [wf (coding-workflow + (string-append + "! grep -q 'qt-timer-on-timeout!\\|qt-widget-grab-to-png!\\|qt-app-exit!\\|Qt::Key_\\|string->integer\\|(<<\\|(>>' " + target) + vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "write" + (list (cons "path" target) + (cons "content" bad)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "qt-alias-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "repair Qt API aliases" resp + (list (cons 'max-iterations 6) + (cons 'max-tool-errors 0) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: Qt API aliases auto-repair to done" + result "qt-alias-ok") + (check-pred! "verified-run: Qt API aliases write compatible names" + (slurp target-path) + (lambda (s) + (and (str-contains? s "qt-on-timeout!") + (str-contains? s "qt-widget-screenshot!") + (str-contains? s "qt-app-quit!") + (str-contains? s "16777234") + (str-contains? s "16777236") + (str-contains? s "16777237") + (str-contains? s "16777235") + (str-contains? s "32") + (str-contains? s "16777216") + (str-contains? s "(= key 80)") + (str-contains? s "(= key 81)") + (str-contains? s "(bitwise-arithmetic-shift s 13)") + (str-contains? s "(bitwise-arithmetic-shift s -17)") + (not (str-contains? s "qt-timer-on-timeout!")) + (not (str-contains? s "qt-widget-grab-to-png!")) + (not (str-contains? s "qt-app-exit!")) + (not (str-contains? s "Qt::Key_")) + (not (str-contains? s "string->integer")) + (not (str-contains? s "(<<")) + (not (str-contains? s "(>>"))))) + (check-pred! "verified-run: Qt API aliases report automatic repair" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) + "including Qt aliases"))))) + (safe-delete-test-file! target-path)) + +(let* ([vr-dir "/tmp"] [target "jcode-verified-missing-create-schema.ss"] [target-path (string-append vr-dir "/" target)] [bad "(import (jerboa prelude))\n(define (main)\n (displayln \"bad\")))\n"]