Improve MCP external library API guidance
ober
4327083e6b8bb92aa7b26b039239630af602c5e9
--- a/Makefile +++ b/Makefile @@ -817,6 +817,7 @@ binary-cross: chez build chez-cross # ship the updated knowledge base. MCP_ENTRY = mcp/server.ss MCP_TEST = mcp/test/protocol-test.ss +MCP_EXTERNAL_TEST = mcp/test/external-lib-test.ss .PHONY: mcp mcp-run mcp-test mcp-test-binary mcp-check jmcp jmcp-portable \ jmcp-macos-amd64 jmcp-linux-amd64 jmcp-linux-arm64 \ jmcp-freebsd-amd64 jmcp-freebsd-arm64 @@ -848,12 +849,18 @@ mcp-run: mcp-test: chez mcp-check native @$(NATIVE_TEST_ENV) JERBOA_MCP_MODE=full JERBOA_MCP_SCHEME_PATH=$(SCHEME) \ $(SCHEME) --libdirs $(LIBDIRS) --script $(MCP_TEST) + @$(NATIVE_TEST_ENV) JERBOA_MCP_MODE=full JERBOA_MCP_SCHEME_PATH=$(SCHEME) \ + $(SCHEME) --libdirs $(LIBDIRS) --script $(MCP_EXTERNAL_TEST) mcp-test-binary: jmcp mcp-check @JERBOA_MCP_MODE=full JERBOA_MCP_SERVER=$(JERBOA_HOME)/jmcp \ JERBOA_MCP_REPO=/tmp/jerboa-mcp-no-data \ JERBOA_HOME=$(JERBOA_HOME) JERBOA_MCP_SCHEME_PATH=$(SCHEME) \ $(SCHEME) --libdirs $(LIBDIRS) --script $(MCP_TEST) + @JERBOA_MCP_MODE=full JERBOA_MCP_SERVER=$(JERBOA_HOME)/jmcp \ + JERBOA_MCP_REPO=/tmp/jerboa-mcp-no-data \ + JERBOA_HOME=$(JERBOA_HOME) JERBOA_MCP_SCHEME_PATH=$(SCHEME) \ + $(SCHEME) --libdirs $(LIBDIRS) --script $(MCP_EXTERNAL_TEST) # Native self-contained binary for the host (./jmcp). Embeds data/*.sexp. jmcp: chez build mcp-check --- a/mcp/server.ss +++ b/mcp/server.ss @@ -1957,15 +1957,25 @@ [source-file (module-source-file normalized dirs)] [candidates (module-candidate-paths normalized dirs)] [hits (filter file-exists? candidates)] + [unreadable-dirs (filter (lambda (dir) + (not (file-directory? dir))) + dirs)] [source-display (or source-file (and (not (null? hits)) (car hits)) "(not found in checked libdirs)")] - [exports (module-exports-list normalized home)]) + [exports (module-exports-list normalized home extra-libdirs)]) (cond [(null? hits) (text-result - (string-append "Module " normalized " not found in checked libdirs:\n " - (string-join dirs "\n ")) + (string-append "Module: " normalized + "\nResult: module does not exist in checked libdirs" + "\nChecked libdirs:\n " + (string-join dirs "\n ") + (if (null? unreadable-dirs) + "" + (string-append + "\nUnreadable or missing libdirs:\n " + (string-join unreadable-dirs "\n ")))) #t)] [(not (hash-ref exports "ok")) (text-result (string-append "Error introspecting " normalized ":\n" @@ -2021,15 +2031,35 @@ (if hit (let* ([arity (hash-ref hit "arity")] [module-name (hash-ref catalog "module")] + [kind (hash-ref hit "kind")] [recipes (load-cookbook (data-path "cookbooks.sexp"))] + [source (module-source-file module-name + (append extra-libdirs + (list (libdirs (jerboa-home home)))))] + [source-usage (source-macro-usage source sym)] [example (symbol-usage-example sym module-name - (hash-ref hit "kind") - arity recipes)]) + kind arity recipes)] + [display-kind (signature-kind kind source-usage)] + [usage (or (and source-usage + (hash-ref source-usage "usage")) + example)]) (text-result - (string-append sym ": arity mask " arity - "\nAccepted arity: " (arity-mask-description arity) - "\nModule: " module-name - "\nExample: " example))) + (if (signature-syntax-kind? display-kind) + (string-append sym ": syntax" + "\nKind: " display-kind + "\nModule: " module-name + "\nUsage: " usage + (signature-source-location-line source-usage) + "\nUsage source: " + (if source-usage "source" "fallback")) + (string-append sym ": arity mask " arity + "\nKind: " display-kind + "\nAccepted arity: " (arity-mask-description arity) + "\nModule: " module-name + (if source + (string-append "\nSource: " source) + "") + "\nExample: " usage)))) (loop (cdr rest) errors)))))]))))) (def (tool-apropos args) @@ -2093,6 +2123,62 @@ (def default-bundle-code-limit 2) +(def (qt-task-bundle? task args) + (let ([module (hash-get* args "module_path" "")] + [q (string-downcase task)]) + (or (string-ci-contains? module "jerboa-qt") + (and (or (string-ci-contains? q "qt") + (string-ci-contains? q "jerboa-qt")) + (or (string-ci-contains? q "tetris") + (string-ci-contains? q "paint") + (string-ci-contains? q "screenshot") + (string-ci-contains? q "timer") + (string-ci-contains? q "keyboard")))))) + +(def (qt-dependency-context-bundle args task) + (let* ([home (hash-get* args "jerboa_home" #f)] + [extra-libdirs (tool-extra-libdirs args #f home)] + [source (module-source-file "(jerboa-qt qt)" + (append extra-libdirs + (list (libdirs (jerboa-home home)))))] + [with-app (source-macro-usage source "with-qt-app")] + [with-app-usage (or (and with-app (hash-ref with-app "usage")) + "(with-qt-app app body ...)")]) + (string-append + "Qt dependency context bundle\n" + "Task: " task "\n" + "Module: (jerboa-qt qt)\n" + "Source: " (or source "(not found; pass extra_libdirs with jerboa-qt/lib)") "\n\n" + "Imports:\n" + "- (import (jerboa prelude))\n" + "- (import (jerboa-qt qt))\n\n" + "Core forms:\n" + "- " with-app-usage " ; binds an app variable and manages Qt app lifecycle\n" + "- (qt-main-window-create) or (qt-main-window-create parent)\n" + "- (qt-paint-widget-create) or (qt-paint-widget-create parent)\n" + "- (qt-widget-resize! widget width height)\n" + "- (qt-main-window-set-central-widget! window widget)\n" + "- (qt-widget-show! widget)\n\n" + "Painting:\n" + "- (qt-on-paint! canvas (lambda () ...)) ; handler takes no args\n" + "- Use (qt-paint-widget-painter canvas) only inside the paint callback.\n" + "- (qt-painter-fill-rect! painter x y width height r g b a)\n" + "- Request redraw with (qt-paint-widget-update! canvas).\n\n" + "Input and timers:\n" + "- (qt-on-key-press! window (lambda () ...)) ; handler takes no args\n" + "- Read the key inside the handler with (qt-last-key-code).\n" + "- (qt-timer-create), (qt-on-timeout! timer (lambda () ...)), (qt-timer-start! timer msec), (qt-timer-stop! timer)\n\n" + "Offscreen self-test:\n" + "- Set QT_QPA_PLATFORM=offscreen in the test environment.\n" + "- Pump events with (qt-pump-events! app); use this current API name consistently.\n" + "- Save evidence with (qt-widget-screenshot! window path); ensure the file is non-empty.\n" + "- In self-tests, avoid qt-app-exec!; pump events, assert state, print OK, and exit.\n\n" + "Useful full recipes:\n" + "- jerboa_howto_get {\"id\":\"jerboa-qt-example-wrapper-jerbuild\"}\n" + "- jerboa_howto_get {\"id\":\"jerboa-qt-offscreen-screenshot-smoke\"}\n" + "- jerboa_howto_get {\"id\":\"jerboa-qt-stateful-board-key-redraw\"}\n" + "- jerboa_howto_get {\"id\":\"jerboa-qt-offscreen-timer-redraw\"}\n"))) + (def (recipe-bundle-entry recipe include-code? auto-code? index) (if (or include-code? (and auto-code? (< index default-bundle-code-limit))) (recipe-text recipe #f) @@ -2143,6 +2229,8 @@ [recipes (load-cookbook path)]) (if (= (string-length task) 0) (text-result "task, query, or description is required." #t) + (if (qt-task-bundle? task args) + (text-result (qt-dependency-context-bundle args task)) (let* ([matches (bounded-take (rank-matching-recipes recipes task kind) limit)] @@ -2176,7 +2264,7 @@ "Recipe summaries only; call jerboa_howto_get with a recipe id before copying a pattern.\n"]) (string-join entries "\n\n") "\n\n" - (cookbook-bundle-workflow task kind file project anti-patterns-path anti-patterns-limit)))))))) + (cookbook-bundle-workflow task kind file project anti-patterns-path anti-patterns-limit))))))))) (def (line-comment-index line) (string-index line #\;)) @@ -4521,6 +4609,118 @@ "(with-resource ([port (open-input-file \"data.txt\")]) (read port))"] [else #f])) +(def (write-datum-string x) + (with-output-to-string (lambda () (write x)))) + +(def (datum-usage-token x) + (cond + [(symbol? x) (symbol->string x)] + [else (write-datum-string x)])) + +(def (syntax-pattern-usage symbol pattern) + (and (pair? pattern) + (let ([tail (cdr pattern)]) + (string-append "(" symbol + (if (null? tail) + "" + (string-append " " + (string-join + (map datum-usage-token tail) + " "))) + ")")))) + +(def (syntax-rules-clause-pattern clause) + (cond + [(and (pair? clause) (eq? (car clause) 'list) (pair? (cdr clause))) + (cadr clause)] + [(pair? clause) (car clause)] + [else #f])) + +(def (define-syntax-usage-form form symbol) + (and (pair? form) + (eq? (car form) 'define-syntax) + (pair? (cdr form)) + (symbol? (cadr form)) + (string=? (symbol->string (cadr form)) symbol) + (pair? (cddr form)) + (let ([rhs (caddr form)]) + (and (pair? rhs) + (eq? (car rhs) 'syntax-rules) + (pair? (cdr rhs)) + (pair? (cddr rhs)) + (let ([clause (car (cddr rhs))]) + (syntax-pattern-usage symbol + (syntax-rules-clause-pattern clause))))))) + +(def (drop-n xs n) + (if (or (<= n 0) (null? xs)) + xs + (drop-n (cdr xs) (- n 1)))) + +(def (last-item xs) + (cond + [(null? xs) #f] + [(null? (cdr xs)) (car xs)] + [else (last-item (cdr xs))])) + +(def (collect-balanced-form-from-lines lines start-index) + (let loop ([rest (drop-n lines start-index)] [buf '()]) + (cond + [(null? rest) #f] + [else + (let* ([buf* (cons (car rest) buf)] + [raw (string-join (reverse buf*) "\n")] + [depths (line-depths raw)] + [last-depth (and (pair? depths) (caddr (last-item depths)))]) + (if (and last-depth (= last-depth 0)) + raw + (loop (cdr rest) buf*)))]))) + +(def (source-macro-usage source-file symbol) + (and source-file + (file-exists? source-file) + (let* ([source (guard (e [else ""]) (read-file-string source-file))] + [lines (string-split source #\newline)]) + (let loop ([rest lines] [index 0] [line-no 1]) + (cond + [(null? rest) #f] + [else + (let ([trimmed (string-trim (car rest))]) + (if (string-prefix? (string-append "(define-syntax " symbol) + trimmed) + (let* ([raw (collect-balanced-form-from-lines lines index)] + [form (and raw + (guard (e [else #f]) + (jerboa-read + (open-string-input-port raw))))] + [usage (and form + (define-syntax-usage-form form symbol))]) + (and usage + (jhash "usage" usage + "source" source-file + "line" line-no))) + (loop (cdr rest) (+ index 1) (+ line-no 1))))]))))) + +(def (signature-kind catalog-kind source-usage) + (cond + [source-usage "syntax"] + [(or (string=? catalog-kind "proc") + (string=? catalog-kind "procedure")) + "procedure"] + [(string=? catalog-kind "?") "unknown"] + [else catalog-kind])) + +(def (signature-syntax-kind? kind) + (or (string=? kind "syntax") (string=? kind "macro"))) + +(def (signature-source-location-line source-usage) + (if source-usage + (string-append "\nSource: " + (hash-ref source-usage "source") + ":" + (number->string (hash-ref source-usage "line"))) + "")) + (def (line-contains-symbol-call? line symbol) (let ([trimmed (string-trim line)]) (and (> (string-length trimmed) 0) new file mode 100644 --- /dev/null +++ b/mcp/test/external-lib-test.ss @@ -0,0 +1,178 @@ +(import (except (jerboa prelude) make-time)) +(import (only (chezscheme) make-time sleep)) +(import (jerboa reader)) +(import (std text json)) +(import (std misc ports)) +(import (std misc process)) +(import (std os path)) +(import (std os env)) +(import (std os temporaries)) +(import (std misc string)) + +(def (env name default) + (def v (getenv name)) + (if (and v (> (string-length v) 0)) v default)) + +(def repo-root (current-directory)) +(def jerboa-home (env "JERBOA_HOME" (path-join (getenv "HOME") "mine" "jerboa"))) +(def scheme-path (env "JERBOA_MCP_SCHEME_PATH" "scheme")) +(def server-path (env "JERBOA_MCP_SERVER" "")) + +(def checks 0) +(def failures 0) + +(def (check label condition) + (set! checks (+ checks 1)) + (unless condition + (set! failures (+ failures 1)) + (display "FAIL: ") + (display label) + (newline))) + +(def (request id method params) + (json-object->string + (alist->hash-table + (list (cons "jsonrpc" "2.0") + (cons "id" id) + (cons "method" method) + (cons "params" params))))) + +(def (call-tool id name arguments) + (request id "tools/call" + (alist->hash-table + (list (cons "name" name) + (cons "arguments" arguments))))) + +(def (run-server requests) + (def proc + (if (> (string-length server-path) 0) + (open-process (list server-path)) + (open-process + (list scheme-path + "--libdirs" (path-join jerboa-home "lib") + "--script" (path-join repo-root "mcp" "server.ss"))))) + (def in (process-port-rec-stdin-port proc)) + (for-each + (lambda (line) + (display line in) + (newline in)) + requests) + (close-port in) + (let ([output (read-all-as-string (process-port-rec-stdout-port proc))] + [err (read-all-as-string (process-port-rec-stderr-port proc))]) + (when (> (string-length err) 0) + (display "server stderr:\n") + (display err) + (newline)) + (map string->json-object + (filter (lambda (line) (> (string-length (string-trim line)) 0)) + (string-split output #\newline))))) + +(def (result response) (hash-ref response "result")) +(def (content-text call-result) + (hash-ref (car (hash-ref call-result "content")) "text")) +(def (is-error? call-result) (hash-ref call-result "isError" #f)) + +(def root (make-temporary-file-name "jmcp-external-lib")) +(def lib-dir (path-join root "lib")) +(def demo-dir (path-join lib-dir "demo")) +(def api-file (path-join demo-dir "api.sls")) +(run-process/batch (list "mkdir" "-p" demo-dir)) +(write-file-string + api-file + "(library (demo api)\n (export fixed answer with-demo)\n (import (rnrs))\n (define answer 42)\n (define (fixed a b) (+ a b))\n (define-syntax with-demo\n (syntax-rules ()\n [(_ ctx body ...)\n (let ([ctx 'demo]) body ...)])))\n") + +(def args-with-extra + (alist->hash-table + (list (cons "module_path" "(demo api)") + (cons "project_path" root) + (cons "extra_libdirs" (list "lib"))))) + +(def responses + (run-server + (list + (request 1 "initialize" + (alist->hash-table + (list (cons "protocolVersion" "2024-11-05") + (cons "capabilities" (make-hash-table)) + (cons "clientInfo" (alist->hash-table '()))))) + (call-tool 2 "jerboa_module_exists" args-with-extra) + (call-tool 3 "jerboa_module_exports" args-with-extra) + (call-tool 4 "jerboa_module_exports" + (alist->hash-table + (list (cons "module_path" "(demo api)")))) + (call-tool 5 "jerboa_function_signature" + (alist->hash-table + (list (cons "symbol" "fixed") + (cons "imports" (list "(demo api)")) + (cons "project_path" root) + (cons "extra_libdirs" (list "lib"))))) + (call-tool 6 "jerboa_function_signature" + (alist->hash-table + (list (cons "symbol" "with-demo") + (cons "imports" (list "(demo api)")) + (cons "project_path" root) + (cons "extra_libdirs" (list "lib"))))) + (call-tool 7 "jerboa_cookbook_task_bundle" + (alist->hash-table + (list (cons "task" "Qt Tetris self-test") + (cons "module_path" "(jerboa-qt qt)") + (cons "extra_libdirs" + (list (path-join (getenv "HOME") + "mine/jerboa-qt/lib"))))))))) + +(def exists-text (content-text (result (list-ref responses 1)))) +(def exports-text (content-text (result (list-ref responses 2)))) +(def missing-exports (result (list-ref responses 3))) +(def fixed-text (content-text (result (list-ref responses 4)))) +(def macro-text (content-text (result (list-ref responses 5)))) +(def qt-bundle-text (content-text (result (list-ref responses 6)))) +(def cookbook-text (read-file-string (path-join repo-root "data" "cookbooks.sexp"))) + +(check "module_exists honors relative extra_libdirs" + (and (not (is-error? (result (list-ref responses 1)))) + (string-contains exists-text "exists: true") + (string-contains exists-text api-file))) +(check "module_exports honors same extra_libdirs" + (and (not (is-error? (result (list-ref responses 2)))) + (string-contains exports-text "fixed") + (string-contains exports-text "answer") + (string-contains exports-text "with-demo"))) +(check "module_exports without external root fails diagnostically" + (and (is-error? missing-exports) + (string-contains (content-text missing-exports) "Module: (demo api)") + (string-contains (content-text missing-exports) "Checked libdirs"))) +(check "procedure signature keeps exact arity" + (and (string-contains fixed-text "Kind: procedure") + (string-contains fixed-text "Accepted arity: 2") + (string-contains fixed-text "Module: (demo api)"))) +(check "macro signature reports syntax kind" + (and (string-contains macro-text "Kind: syntax") + (string-contains macro-text "Usage: (with-demo ctx body ...)") + (string-contains macro-text "Source: ") + (not (string-contains macro-text "Accepted arity: unknown")))) +(check "qt dependency context is compact and current" + (and (< (string-length qt-bundle-text) 4096) + (string-contains qt-bundle-text "Qt dependency context bundle") + (string-contains qt-bundle-text "(with-qt-app app body ...)") + (string-contains qt-bundle-text "qt-pump-events!") + (not (string-contains qt-bundle-text "qt-app-process-events!")))) +(check "active cookbooks use current qt pump API" + (and (string-contains cookbook-text "qt-pump-events!") + (not (string-contains cookbook-text "qt-app-process-events!")))) + +(run-process/batch (list "rm" "-rf" root)) + +(if (= failures 0) + (begin + (display (string-append "external-lib-test: PASS (" + (number->string checks) + " checks)")) + (newline) + (exit 0)) + (begin + (display (string-append "external-lib-test: FAIL (" + (number->string failures) + " failures)")) + (newline) + (exit failures))) --- a/mcp/test/protocol-test.ss +++ b/mcp/test/protocol-test.ss @@ -1241,7 +1241,8 @@ (check "module exports distinguishes missing module" (and (hash-ref (result (list-ref responses 112)) "isError") - (string-contains (content-text (result (list-ref responses 112))) "not found in checked libdirs"))) + (string-contains (content-text (result (list-ref responses 112))) + "module does not exist in checked libdirs"))) (check "dispatcher search finds howto add aliases" (string-contains (content-text (result (list-ref responses 113))) "howto_add"))