Reject import-only source creates
ober
ef915682ab8ca131359ce396b05d25eaec53e638
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -4294,6 +4294,19 @@ (string-contains content "(export") (string-contains content "(import"))) +(def (ss-create-has-substantive-form? content) + (or (string-contains content "(def ") + (string-contains content "(define ") + (string-contains content "(lambda") + (string-contains content "(let ") + (string-contains content "(let* ") + (string-contains content "(display"))) + +(def (complete-ss-create-content? path content) + (and (source-ss-path? path) + (looks-like-complete-file? content) + (ss-create-has-substantive-form? content))) + (def meaningful-source-bytes-threshold 1000) (def tiny-rewrite-bytes-threshold 500) @@ -5170,7 +5183,7 @@ (let ((new-content (or new-str ""))) (cond ((and (source-ss-path? path) - (not (looks-like-complete-file? new-content))) + (not (complete-ss-create-content? path new-content))) (reject-incomplete-ss-create path new-content "replacement snippets")) (else @@ -5223,7 +5236,7 @@ cwd path content 'edit "complete replacement")) ((and (not (file-exists? p)) (source-ss-path? path) - (not (looks-like-complete-file? content))) + (not (complete-ss-create-content? path content))) (reject-incomplete-ss-create path content "full-write snippets")) ((and (not (file-exists? p)) --- a/test/run.ss +++ b/test/run.ss @@ -9356,6 +9356,54 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-import-only-create.ss"] + [target-path (string-append vr-dir "/" target)] + [stub "(import (jerboa prelude) (jerboa-qt qt))\n"] + [full "(import (jerboa prelude) (jerboa-qt qt))\n(define (main) 1)\n"] + [tool-results '()] + [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)] + [wf (coding-workflow (string-append "test -s " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "write" + (list (cons "path" target) + (cons "content" stub)) + #f)) + (list + (make-wtool-call + "write" + (list (cons "path" target) + (cons "content" full)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "import-only-create-guard")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "reject import-only ss create" resp + (list (cons 'max-iterations 8) + (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: .ss import-only create rejects stubs" + result "import-only-create-guard") + (check! "verified-run: .ss import-only retry writes full file" + (slurp target-path) full) + (check-pred! "verified-run: .ss import-only create explains full-file requirement" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) "[ToolRecoverableError]") + (str-contains? (car xs) "missing .ss target requires complete file contents"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-verified-snippet-create-content.ss"] [target-path (string-append vr-dir "/" target)] [snippet "(define (main) 1)\n"]