(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)))

(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)))))))

(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)))))))))

(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))))))))

(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)
                    (list :status :success
                          :content (format nil "Written ~d bytes to ~a" (length content) filepath)))
                (error (c) (list :status :error :message (format nil "~a" c))))))))

(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)))))))))

(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))))))))

(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))))))))

(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))))))))

(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))))))))

(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))))))))

(defskill :passepartout-programming-tools
  :priority 50
  :trigger (lambda (ctx) (declare (ignore ctx)) nil)
  :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))

(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))

(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))))

(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)

(defvar *skill-registry* (make-hash-table :test 'equal)
  "Global registry of all loaded skills.")

(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)))))

(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))

(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))))