Amr Gharbeia
924bf8f479
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- Restore (in-package :passepartout) to core-reason - Move *VAULT-MEMORY* back to core-skills - Fix ASDF and defstruct/defpackage ordering - Increase daemon timeout to 120s - Handshake: 0.5.0 Verified: daemon processes messages, TUI clean, gate trace works
104 lines
4.4 KiB
Common Lisp
104 lines
4.4 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defun literate-extract-lisp-blocks (content)
|
|
"Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT.
|
|
Returns a list of block strings."
|
|
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(blocks nil)
|
|
(in-block nil)
|
|
(current-block nil))
|
|
(dolist (line lines)
|
|
(let ((trimmed (string-trim '(#\Space) line)))
|
|
(cond
|
|
((uiop:string-prefix-p "#+begin_src lisp" trimmed)
|
|
(setf in-block t current-block nil))
|
|
((uiop:string-prefix-p "#+end_src" trimmed)
|
|
(when in-block
|
|
(push (format nil "~{~a~^~%~}" (nreverse current-block)) blocks)
|
|
(setf in-block nil current-block nil)))
|
|
(in-block
|
|
(push line current-block)))))
|
|
(nreverse blocks)))
|
|
|
|
(defun literate-block-balance-check (org-file)
|
|
"Verifies that all Lisp source blocks in an Org file have balanced parentheses.
|
|
Returns T if all blocks pass validation, or an error string listing failures."
|
|
(when (not (uiop:file-exists-p org-file))
|
|
(return-from literate-block-balance-check
|
|
(format nil "Org file not found: ~a" org-file)))
|
|
(let* ((content (uiop:read-file-string org-file))
|
|
(blocks (literate-extract-lisp-blocks content))
|
|
(failures nil))
|
|
(if (null blocks)
|
|
t
|
|
(progn
|
|
(loop for i from 0
|
|
for block in blocks
|
|
for (ok reason) = (multiple-value-list
|
|
(lisp-structural-check block))
|
|
unless ok
|
|
do (push (format nil "Block ~d: ~a" (1+ i) reason) failures))
|
|
(if failures
|
|
(format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures)
|
|
t)))))
|
|
|
|
(defun literate-tangle-sync-check (org-file lisp-file)
|
|
"Verifies that the .lisp file matches the tangled output of the .org file.
|
|
Compares the concatenation of all lisp blocks from the Org file against the
|
|
contents of the Lisp file. Returns T if they match, or an error message."
|
|
(when (not (uiop:file-exists-p org-file))
|
|
(return-from literate-tangle-sync-check
|
|
(format nil "Org file not found: ~a" org-file)))
|
|
(when (not (uiop:file-exists-p lisp-file))
|
|
(return-from literate-tangle-sync-check
|
|
(format nil "Lisp file not found: ~a" lisp-file)))
|
|
(let* ((org-content (uiop:read-file-string org-file))
|
|
(org-blocks (literate-extract-lisp-blocks org-content))
|
|
(tangled (format nil "~{~a~^~%~%~}" org-blocks))
|
|
(lisp-content (uiop:read-file-string lisp-file)))
|
|
(if (string= (string-trim '(#\Space #\Newline) tangled)
|
|
(string-trim '(#\Space #\Newline) lisp-content))
|
|
t
|
|
(format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file))))
|
|
|
|
(defskill :passepartout-programming-literate
|
|
:priority 300
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-programming-literate-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:literate-suite))
|
|
|
|
(in-package :passepartout-programming-literate-tests)
|
|
|
|
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
|
(in-suite literate-suite)
|
|
|
|
(test test-extract-lisp-blocks
|
|
"Contract 1: extracts lisp from #+begin_src blocks."
|
|
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
|
(extracted (literate-extract-lisp-blocks org-content)))
|
|
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
|
(is (search "(+ 1 2)" joined))
|
|
(is (search "(+ 3 4)" joined)))))
|
|
|
|
(test test-block-balance-check-valid
|
|
"Contract 2: balanced parens return T."
|
|
(is (eq t (literate-block-balance-check
|
|
(merge-pathnames "org/core-pipeline.org"
|
|
(uiop:ensure-directory-pathname
|
|
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
|
|
|
(test test-block-balance-check-missing-close
|
|
"Contract 2: unbalanced parens return non-T."
|
|
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
|
|
|
(test test-tangle-sync-check
|
|
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
|
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
|
(is (or (eq t result) (stringp result))
|
|
"Should return T or a mismatch description")))
|