Amr Gharbeia
96370cc4b1
Per-tool timeouts: shell=300s, search-files=30s, eval-form=10s, unknown=120s default. Write verification: after write-file, reads back content and compares, logs mismatches. - core-act: *tool-timeouts* hash, tool-timeout, verify-write - programming-tools: verify-write call in write-file body - Act tests: +3 (timeout shell, timeout unknown, verify match) - Core: 84/84
754 lines
31 KiB
Org Mode
754 lines
31 KiB
Org Mode
#+TITLE: SKILL: Programming Tools (programming-tools.org)
|
|
#+AUTHOR: Agent
|
|
#+FILETAGS: :programming:tools:cognitive:
|
|
#+PROPERTY: header-args:lisp :tangle ../lisp/programming-tools.lisp
|
|
|
|
* Cognitive Tools for Codebase Operations
|
|
|
|
This skill registers ten cognitive tools that let the LLM search codebases, read and write files, evaluate Lisp expressions, run tests, and manipulate Org files. Without these tools, the agent can chat and run shell commands but cannot perform the core operations of a programming assistant.
|
|
|
|
Each tool is registered via ~def-cognitive-tool~ and appears in the LLM's tool belt prompt via ~cognitive-tool-prompt~. Tools receive arguments as a plist and return a plist with ~:status~ (~:success or :error~) and either ~:content~ (success) or ~:message~ (error). The tool executor (~action-tool-execute~) normalizes nested argument lists, dispatches by name, and feeds results back into the perception pipeline.
|
|
|
|
** Contract
|
|
|
|
1. Every tool returns a plist with at least ~:status~. On success: ~(:status :success :content "...")~. On error: ~(:status :error :message "...")~.
|
|
2. Every tool guards against missing required parameters and returns a clear error message.
|
|
3. Every tool handles runtime exceptions (~handler-case~) — a tool must never crash the daemon.
|
|
4. ~search-files~: given ~:pattern~, ~:path~, optional ~:include~ (glob), returns matched lines with file:line prefixes.
|
|
5. ~find-files~: given ~:pattern~ (glob), ~:path~, returns list of matching file paths.
|
|
6. ~read-file~: given ~:filepath~, optional ~:start~, ~:limit~ (lines), returns file contents.
|
|
7. ~write-file~: given ~:filepath~, ~:content~, creates directories, writes file, returns byte count.
|
|
8. ~list-directory~: given ~:path~, optional ~:pattern~, returns sorted directory entries.
|
|
9. ~run-shell~: given ~:cmd~, optional ~:timeout~, returns stdout, stderr, and exit code.
|
|
10. ~eval-form~: given ~:code~ (Lisp expression string), returns evaluated result. Disables ~*read-eval*~.
|
|
11. ~run-tests~: given optional ~:test-name~, runs specific test or all suites via ~fiveam:run-all-tests~.
|
|
12. ~org-find-headline~: given ~:id~ or ~:title~, searches ~*memory-store*~ for matching memory objects.
|
|
13. ~org-modify-file~: given ~:filepath~, ~:old-text~, ~:new-text~, performs exact-string replacement. Returns error if text not found.
|
|
|
|
* Implementation
|
|
|
|
** Package Context
|
|
#+begin_src lisp
|
|
(in-package :passepartout)
|
|
|
|
(defun tools-write-file (filepath content)
|
|
"Write string CONTENT to FILEPATH, creating parent directories."
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
#+end_src
|
|
|
|
** Tool: search-files
|
|
|
|
Searches file contents recursively under a directory using regex pattern matching.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool search-files
|
|
"Search file contents under a directory for a regex pattern."
|
|
((:name "pattern" :description "The regex pattern to search for." :type "string")
|
|
(:name "path" :description "Directory to search recursively." :type "string")
|
|
(:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path))
|
|
(include (getf args :include))
|
|
(results nil))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "search-files requires :pattern and :path")))
|
|
(handler-case
|
|
(dolist (file (directory (merge-pathnames
|
|
(if include
|
|
(make-pathname :name :wild :type (subseq include 2) :defaults path)
|
|
(make-pathname :name :wild :type :wild :defaults path))
|
|
path)))
|
|
(let ((base (file-namestring file)))
|
|
(with-open-file (stream file :direction :input :if-does-not-exist nil)
|
|
(when stream
|
|
(loop for line = (read-line stream nil nil)
|
|
for line-num from 1
|
|
while line
|
|
when (cl-ppcre:scan pattern line)
|
|
do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line))
|
|
results))))))
|
|
(t (c) (return (list :status :error :message (format nil "~a" c)))))
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d matches:~%~a" (length results)
|
|
(format nil "~{~a~^~%~}" (reverse results)))
|
|
(format nil "No matches for '~a' in ~a" pattern path)))))))
|
|
#+end_src
|
|
|
|
** Tool: find-files
|
|
|
|
Glob file matching using SBCL's ~directory~.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool find-files
|
|
"Find files matching a glob pattern."
|
|
((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
|
|
(:name "path" :description "Directory to search in." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path)))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "find-files requires :pattern and :path")))
|
|
(let ((full (merge-pathnames pattern path)))
|
|
(handler-case
|
|
(let ((files (directory full)))
|
|
(list :status :success
|
|
:content (if files
|
|
(format nil "~d files:~%~{~a~^~%~}" (length files) files)
|
|
(format nil "No files matching '~a' in ~a" pattern path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
#+end_src
|
|
|
|
** Tool: read-file
|
|
|
|
Reads a file into a string. Supports optional ~:start~ and ~:limit~ for partial reads.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool read-file
|
|
"Read the contents of a file."
|
|
((:name "filepath" :description "Path to the file to read." :type "string")
|
|
(:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
|
|
(:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
|
|
:read-only-p t
|
|
:guard (lambda (args) (declare (ignore args)) nil)
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(start (getf args :start))
|
|
(limit (getf args :limit)))
|
|
(unless filepath
|
|
(return (list :status :error :message "read-file requires :filepath")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(if (or start limit)
|
|
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(start-idx (max 0 (1- (or start 1))))
|
|
(end (if limit (min (length lines) (+ start-idx limit)) (length lines)))
|
|
(selected (subseq lines start-idx end)))
|
|
(list :status :success
|
|
:content (format nil "~{~a~^~%~}" selected)))
|
|
(list :status :success :content content)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: write-file
|
|
|
|
Writes string content to a file, creating parent directories as needed.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool write-file
|
|
"Write string content to a file. Created directories as needed."
|
|
((:name "filepath" :description "Path to the file to write." :type "string")
|
|
(:name "content" :description "The text content to write." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(content (getf args :content)))
|
|
(unless (and filepath content)
|
|
(return (list :status :error :message "write-file requires :filepath and :content")))
|
|
(handler-case
|
|
(progn
|
|
(tools-write-file filepath content)
|
|
(verify-write filepath content)
|
|
(list :status :success
|
|
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: list-directory
|
|
|
|
Lists the contents of a directory, optionally filtered by a glob pattern.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool list-directory
|
|
"List the contents of a directory."
|
|
((:name "path" :description "Directory path to list." :type "string")
|
|
(:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((path (getf args :path))
|
|
(pattern (getf args :pattern)))
|
|
(unless path
|
|
(return (list :status :error :message "list-directory requires :path")))
|
|
(let ((full-pattern (if pattern
|
|
(merge-pathnames pattern path)
|
|
(make-pathname :name :wild :type :wild :defaults path))))
|
|
(handler-case
|
|
(let ((entries (directory full-pattern)))
|
|
(list :status :success
|
|
:content (if entries
|
|
(format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries)
|
|
(format nil "No entries in ~a" path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
#+end_src
|
|
|
|
** Tool: run-shell
|
|
|
|
Executes a shell command and returns stdout, stderr, and exit code.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool run-shell
|
|
"Execute a shell command and return stdout, stderr, and exit code."
|
|
((:name "cmd" :description "The shell command to execute." :type "string")
|
|
(:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((cmd (getf args :cmd))
|
|
(timeout (or (getf args :timeout) 30)))
|
|
(unless cmd
|
|
(return (list :status :error :message "run-shell requires :cmd")))
|
|
(handler-case
|
|
(multiple-value-bind (out err code)
|
|
(uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
|
|
:output :string :error-output :string
|
|
:ignore-error-status t)
|
|
(list :status :success
|
|
:content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d"
|
|
(or out "") (when (and err (> (length err) 0)) err) code)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: eval-form
|
|
|
|
Evaluates a Lisp expression in the running image. Binds ~*read-eval*~ to nil for safety.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool eval-form
|
|
"Evaluate a Lisp expression in the running image and return the result."
|
|
((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((code (getf args :code)))
|
|
(unless code
|
|
(return (list :status :error :message "eval-form requires :code")))
|
|
(handler-case
|
|
(let* ((*read-eval* nil)
|
|
(form (read-from-string code))
|
|
(result (eval form)))
|
|
(list :status :success :content (format nil "~a" result)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: run-tests
|
|
|
|
Runs FiveAM test suites. Without arguments, runs all tests via ~fiveam:run-all-tests~.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool run-tests
|
|
"Run FiveAM tests. With no arguments, runs all test suites."
|
|
((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((test-name (getf args :test-name)))
|
|
(handler-case
|
|
(if test-name
|
|
(let* ((sym (find-symbol (string-upcase test-name) :passepartout))
|
|
(result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout)))))
|
|
(list :status :success
|
|
:content (format nil "Test '~a' ~a" test-name
|
|
(if result "completed" "not found"))))
|
|
(let ((result (fiveam:run-all-tests)))
|
|
(list :status :success :content (format nil "~a" result))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: org-find-headline
|
|
|
|
Finds Org headlines in the memory store by ID property or title substring match.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool org-find-headline
|
|
"Find an Org headline by ID or title in the memory store."
|
|
((:name "id" :description "Optional: Org ID property to search for." :type "string")
|
|
(:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
|
|
:read-only-p t
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((id (getf args :id))
|
|
(title (getf args :title))
|
|
(results nil))
|
|
(unless (or id title)
|
|
(return (list :status :error :message "org-find-headline requires :id or :title")))
|
|
(handler-case
|
|
(let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout))
|
|
(get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout))
|
|
(get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout)))
|
|
(unless (and is-mem get-id get-title)
|
|
(return (list :status :error :message "Memory store not loaded")))
|
|
(maphash (lambda (k obj)
|
|
(declare (ignore k))
|
|
(when (and (funcall is-mem obj)
|
|
(or (and id (string-equal id (funcall get-id obj)))
|
|
(and title (search title (funcall get-title obj) :test #'char-equal))))
|
|
(push obj results)))
|
|
*memory-store*)
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d headlines found:~%~{~a~^~%~}"
|
|
(length results)
|
|
(mapcar (lambda (r) (funcall get-title r)) results))
|
|
(format nil "No headlines matching ~a" (or id title)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Tool: org-modify-file
|
|
|
|
Surgical text replacement in an Org file — matches exact text and replaces it.
|
|
|
|
#+begin_src lisp
|
|
(def-cognitive-tool org-modify-file
|
|
"Replace text in an Org file via exact string match. Returns error if old-text not found."
|
|
((:name "filepath" :description "Path to the Org file." :type "string")
|
|
(:name "old-text" :description "Exact text to replace." :type "string")
|
|
(:name "new-text" :description "Text to insert in its place." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(old-text (getf args :old-text))
|
|
(new-text (getf args :new-text)))
|
|
(unless (and filepath old-text new-text)
|
|
(return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(let ((pos (search old-text content)))
|
|
(if pos
|
|
(let ((new-content (concatenate 'string
|
|
(subseq content 0 pos)
|
|
new-text
|
|
(subseq content (+ pos (length old-text))))))
|
|
(tools-write-file filepath new-content)
|
|
(list :status :success
|
|
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
|
|
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
#+end_src
|
|
|
|
** Skill Registration
|
|
|
|
#+begin_src lisp
|
|
(defskill :passepartout-programming-tools
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
|
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
|
#+end_src
|
|
|
|
|
|
** Package Definition and Export List
|
|
The package definition. All public symbols are exported here.
|
|
#+begin_src lisp
|
|
(defpackage :passepartout
|
|
(:use :cl)
|
|
(:export
|
|
#:frame-message
|
|
#:read-framed-message
|
|
#:PROTO-GET
|
|
#:proto-get
|
|
#:*VAULT-MEMORY*
|
|
#:make-hello-message
|
|
#:validate-communication-protocol-schema
|
|
#:start-daemon
|
|
#:log-message
|
|
#:main
|
|
#:diagnostics-run-all
|
|
#:diagnostics-main
|
|
#:diagnostics-dependencies-check
|
|
#:diagnostics-env-check
|
|
#:register-provider
|
|
#:provider-openai-request
|
|
#:provider-config
|
|
#:run-setup-wizard
|
|
#:ingest-ast
|
|
#:memory-object-get
|
|
#:*memory-store*
|
|
#:memory-object
|
|
#:make-memory-object
|
|
#:memory-object-id
|
|
#:memory-object-type
|
|
#:memory-object-attributes
|
|
#:memory-object-parent-id
|
|
#:memory-object-children
|
|
#:memory-object-version
|
|
#:memory-object-last-sync
|
|
#:memory-object-vector
|
|
#:memory-object-content
|
|
#:memory-object-hash
|
|
#:memory-object-scope
|
|
#:snapshot-memory
|
|
#:rollback-memory
|
|
#:context-get-system-logs
|
|
#:context-assemble-global-awareness
|
|
#:context-awareness-assemble
|
|
#:context-query
|
|
#:push-context
|
|
#:pop-context
|
|
#:current-context
|
|
#:current-scope
|
|
#:context-stack-depth
|
|
#:context-save
|
|
#:context-load
|
|
#:focus-project
|
|
#:focus-session
|
|
#:focus-memex
|
|
#:unfocus
|
|
#:process-signal
|
|
#:loop-process
|
|
#:perceive-gate
|
|
#:loop-gate-perceive
|
|
#:act-gate
|
|
#:loop-gate-act
|
|
#:reason-gate
|
|
#:loop-gate-reason
|
|
#:cognitive-verify
|
|
#:backend-cascade-call
|
|
#:json-alist-to-plist
|
|
#:inject-stimulus
|
|
#:stimulus-inject
|
|
#:hitl-create
|
|
#:hitl-approve
|
|
#:hitl-deny
|
|
#:hitl-handle-message
|
|
#:dispatcher-check-secret-path
|
|
#:dispatcher-check-shell-safety
|
|
#:dispatcher-check-privacy-tags
|
|
#:dispatcher-check-network-exfil
|
|
#:dispatcher-gate
|
|
#:wildcard-match
|
|
#:actuator-initialize
|
|
#:action-dispatch
|
|
#:register-actuator
|
|
#:load-skill-from-org
|
|
#:skill-initialize-all
|
|
#:lisp-syntax-validate
|
|
#:defskill
|
|
#:*skill-registry*
|
|
#:*scope-resolver*
|
|
#:*embedding-backend*
|
|
#:*embedding-queue*
|
|
#:*embedding-provider*
|
|
#:embed-queue-object
|
|
#:embed-object
|
|
#:embed-all-pending
|
|
#:embedding-backend-hashing
|
|
#:embedding-backend-native
|
|
#:embedding-native-load-model
|
|
#:embedding-native-unload
|
|
#:embedding-native-ensure-loaded
|
|
#:embedding-native-get-dim
|
|
#:embeddings-compute
|
|
#:mark-vector-stale
|
|
#:skill
|
|
#:skill-name
|
|
#:skill-priority
|
|
#:skill-dependencies
|
|
#:skill-trigger-fn
|
|
#:skill-probabilistic-prompt
|
|
#:skill-deterministic-fn
|
|
#:def-cognitive-tool
|
|
#:*cognitive-tool-registry*
|
|
#:org-read-file
|
|
#:org-write-file
|
|
#:org-headline-add
|
|
#:org-headline-find-by-id
|
|
#:literate-tangle-sync-check
|
|
#:archivist-create-note
|
|
#:gateway-start
|
|
#:org-property-set
|
|
#:org-todo-set
|
|
#:org-id-generate
|
|
#:org-id-format
|
|
#:org-modify
|
|
#:lisp-validate
|
|
#:lisp-structural-check
|
|
#:lisp-syntactic-check
|
|
#:lisp-semantic-check
|
|
#:lisp-eval
|
|
#:lisp-format
|
|
#:lisp-list-definitions
|
|
#:lisp-extract
|
|
#:lisp-inject
|
|
#:lisp-slurp
|
|
#:get-oc-config-dir
|
|
#:get-tool-permission
|
|
#:set-tool-permission
|
|
#:check-tool-permission-gate
|
|
#:permission-get
|
|
#:permission-set
|
|
#:cognitive-tool
|
|
#:cognitive-tool-name
|
|
#:cognitive-tool-description
|
|
#:cognitive-tool-parameters
|
|
#:cognitive-tool-guard
|
|
#:cognitive-tool-body
|
|
#:register-probabilistic-backend
|
|
#:*probabilistic-backends*
|
|
#:*provider-cascade*
|
|
#:vault-get
|
|
#:vault-set
|
|
#:vault-get-secret
|
|
#:vault-set-secret
|
|
#:memory-objects-by-attribute
|
|
#:channel-cli-input
|
|
#:repl-eval
|
|
#:repl-inspect
|
|
#:repl-list-vars
|
|
#:policy-compliance-check
|
|
#:validator-protocol-check
|
|
#:archivist-extract-headlines
|
|
#:archivist-headline-to-filename
|
|
#:literate-extract-lisp-blocks
|
|
#:literate-block-balance-check
|
|
#:gateway-registry-initialize
|
|
#:messaging-link
|
|
#:messaging-unlink
|
|
#:gateway-configured-p))
|
|
#+end_src
|
|
|
|
** Package Implementation
|
|
The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills.
|
|
|
|
*** Robust plist access (plist-get)
|
|
Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions.
|
|
#+begin_src lisp
|
|
(in-package :passepartout)
|
|
|
|
(defun plist-get (plist key)
|
|
"Robust plist accessor — checks both :KEY and :key variants."
|
|
(let* ((s (string key))
|
|
(up (intern (string-upcase s) :keyword))
|
|
(dn (intern (string-downcase s) :keyword)))
|
|
(or (getf plist up) (getf plist dn))))
|
|
#+end_src
|
|
|
|
*** Logging state
|
|
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
|
|
#+begin_src lisp
|
|
(defvar *log-buffer* nil)
|
|
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
|
(defvar *log-limit* 100)
|
|
#+end_src
|
|
|
|
*** Skill registry
|
|
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
|
|
#+begin_src lisp
|
|
(defvar *skill-registry* (make-hash-table :test 'equal)
|
|
"Global registry of all loaded skills.")
|
|
#+end_src
|
|
|
|
*** Skill telemetry
|
|
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
|
|
#+begin_src lisp
|
|
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
|
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
|
|
|
(defun telemetry-track (skill-name duration status)
|
|
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
|
(when skill-name
|
|
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
|
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
|
|
(incf (getf entry :executions))
|
|
(incf (getf entry :total-time) duration)
|
|
(when (eq status :rejected) (incf (getf entry :failures)))
|
|
(setf (gethash skill-name *telemetry-table*) entry)))))
|
|
#+end_src
|
|
|
|
*** Cognitive tool registry
|
|
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt.
|
|
#+begin_src lisp
|
|
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
|
#+end_src
|
|
|
|
* Test Suite
|
|
|
|
#+begin_src lisp
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-programming-tools-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:programming-tools-suite))
|
|
|
|
(in-package :passepartout-programming-tools-tests)
|
|
|
|
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
|
(in-suite programming-tools-suite)
|
|
|
|
(defun tools-tmpdir ()
|
|
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
|
(uiop:ensure-all-directories-exist (list d))
|
|
d))
|
|
|
|
(defun tools-cleanup ()
|
|
(let ((d (tools-tmpdir)))
|
|
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
|
|
|
(defun tools-write-file (filepath content)
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(defun call-tool (tool-name &rest args)
|
|
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
|
(unless tool (error "Tool ~a not found" tool-name))
|
|
(funcall (cognitive-tool-body tool) args)))
|
|
|
|
;; search-files
|
|
(test test-search-files-finds-matches
|
|
"Contract 1: search-files finds lines matching a regex pattern."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file-a (merge-pathnames "src-a.lisp" dir))
|
|
(file-b (merge-pathnames "src-b.lisp" dir)))
|
|
(tools-write-file file-a "(defun foo () 'hello)")
|
|
(tools-write-file file-b "(defun bar () 'world)")
|
|
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "src-a.lisp:1:" (getf result :content)))
|
|
(is (search "src-b.lisp:1:" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-search-files-missing-params
|
|
"search-files returns error when required params are missing."
|
|
(let ((result (call-tool 'search-files :pattern "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; find-files
|
|
(test test-find-files-by-extension
|
|
"Contract 5: find-files returns files matching a glob."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "a.lisp" (getf result :content)))
|
|
(is (search "b.lisp" (getf result :content)))
|
|
(is (not (search "c.org" (getf result :content)))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-find-files-missing-params
|
|
"find-files returns error without required params."
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; read-file
|
|
(test test-read-file-full
|
|
"Contract 6: read-file returns full file contents."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "readme.txt" dir)))
|
|
(tools-write-file file (format nil "line one~%line two~%line three"))
|
|
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "line one" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-read-file-missing-params
|
|
"read-file returns error without :filepath."
|
|
(let ((result (call-tool 'read-file)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; write-file
|
|
(test test-write-file-creates
|
|
"Contract 7: write-file creates file with content."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "output.txt" dir)))
|
|
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "11 bytes" (getf result :content))))
|
|
(is (string-equal "hello world" (uiop:read-file-string file)))
|
|
(tools-cleanup)))
|
|
|
|
(test test-write-file-missing-params
|
|
"write-file returns error without required params."
|
|
(let ((result (call-tool 'write-file :content "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; list-directory
|
|
(test test-list-directory-all
|
|
"Contract 8: list-directory returns all entries."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
|
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
|
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "alpha.txt" (getf result :content)))
|
|
(is (search "beta.txt" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-list-directory-missing-params
|
|
"list-directory returns error without :path."
|
|
(let ((result (call-tool 'list-directory)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; run-shell
|
|
(test test-run-shell-echo
|
|
"Contract 9: run-shell executes a command and returns output."
|
|
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "hello" (getf result :content)))))
|
|
|
|
(test test-run-shell-missing-params
|
|
"run-shell returns error without :cmd."
|
|
(let ((result (call-tool 'run-shell)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; eval-form
|
|
(test test-eval-form-arithmetic
|
|
"Contract 10: eval-form evaluates a Lisp expression."
|
|
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "3" (getf result :content)))))
|
|
|
|
(test test-eval-form-missing-params
|
|
"eval-form returns error without :code."
|
|
(let ((result (call-tool 'eval-form)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; org-modify-file
|
|
(test test-org-modify-file-replace
|
|
"Contract 13: org-modify-file replaces exact text in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "doc.org" dir)))
|
|
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "TODO" :new-text "WAITING")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "WAITING" (uiop:read-file-string file))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-not-found
|
|
"org-modify-file returns error when text not in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "file.org" dir)))
|
|
(tools-write-file file "some content")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "not-in-file" :new-text "anything")))
|
|
(is (eq (getf result :status) :error))
|
|
(is (search "not found" (getf result :message))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-missing-params
|
|
"org-modify-file returns error without required params."
|
|
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
|
(is (eq (getf result :status) :error))))
|
|
#+end_src
|