321 lines
10 KiB
Common Lisp
321 lines
10 KiB
Common Lisp
#-eql5
|
|
(error "Please use the EQL5 executable")
|
|
|
|
(require 'ecl-quicklisp)
|
|
(ql:quickload :fiveam)
|
|
|
|
(use-package :alexandria)
|
|
(use-package :fiveam)
|
|
(use-package :org)
|
|
|
|
(defmacro with-open-org-from-string (str &body body)
|
|
`(progn
|
|
(open-from-string ,str)
|
|
,@body))
|
|
|
|
(defmacro with-open-org-file (pathname &body body)
|
|
`(progn
|
|
(open-file ,pathname)
|
|
,@body
|
|
(close-file)))
|
|
|
|
(defparameter empty-org "")
|
|
|
|
(defparameter test-org-1 "preamble 1
|
|
preamble 2
|
|
* header 1
|
|
line 1
|
|
line 2
|
|
** header 2
|
|
line 3
|
|
line 4
|
|
* header 3
|
|
line 5
|
|
")
|
|
|
|
(defmacro with-test-org-1 (&body body)
|
|
`(let* ((test-org (sextant:make-document-from-string test-org-1))
|
|
(preamble-1 (next-of test-org))
|
|
(preamble-2 (next-of preamble-1))
|
|
(header-1 (next-of preamble-2))
|
|
(line-1 (next-of header-1))
|
|
(line-2 (next-of line-1))
|
|
(header-2 (next-of line-2))
|
|
(line-3 (next-of header-2))
|
|
(line-4 (next-of line-3))
|
|
(header-3 (next-of line-4))
|
|
(line-5 (next-of header-3)))
|
|
,@body))
|
|
|
|
|
|
(defparameter test-org-2 "* header 1
|
|
** sub header 1
|
|
*** sub sub header 1
|
|
** sub header 2
|
|
**** sub sub sub header 1
|
|
*** sub sub header 2
|
|
")
|
|
|
|
(defmacro with-test-org-2 (&body body)
|
|
`(let* ((test-org (sextant:make-document-from-string test-org-2))
|
|
(first-node (next-of test-org))
|
|
(second-node (next-of first-node))
|
|
(third-node (next-of second-node))
|
|
(fourth-node (next-of third-node))
|
|
(fifth-node (next-of fourth-node))
|
|
(sixth-node (next-of fifth-node)))
|
|
,@body))
|
|
|
|
(def-suite all-tests)
|
|
|
|
(def-suite org :in all-tests)
|
|
(in-suite org)
|
|
|
|
(test parse-document
|
|
(is (equal "" (raw-text-of (next-of (sextant:make-document-from-string empty-org)))))
|
|
(is (null (next-of (next-of (sextant:make-document-from-string empty-org)))))
|
|
(let ((test-org (sextant:make-document-from-string test-org-1)))
|
|
(is (= 10 (loop for n = (next-of test-org) then (next-of n)
|
|
until (null n)
|
|
count n)))
|
|
(is (= 3 (loop for h = (next-headline-of test-org) then (next-headline-of h)
|
|
until (null h)
|
|
count h)))
|
|
(is (equal test-org-1 (with-output-to-string (str) (org-print test-org str)))))
|
|
(let ((test-org (sextant:make-document-from-string test-org-2)))
|
|
(is (= 6 (loop for n = (next-of test-org) then (next-of n)
|
|
until (null n)
|
|
count n)))
|
|
(is (= 6 (loop for h = (next-headline-of test-org) then (next-headline-of h)
|
|
until (null h)
|
|
count h)))
|
|
(is (equal test-org-2 (with-output-to-string (str) (org-print test-org str))))))
|
|
|
|
(test headline-of
|
|
(let* ((test-org (sextant:make-document-from-string test-org-1))
|
|
(current-node (next-of test-org)))
|
|
(is (null (headline-of current-node)))
|
|
(let ((first-headline (next-headline-of current-node)))
|
|
(is (equal "header 1" (title-of first-headline)))
|
|
(is (null (headline-of first-headline)))
|
|
(setf current-node (next-of first-headline))
|
|
(is (eq first-headline (headline-of current-node)))
|
|
(is (eq (next-headline-of first-headline) (next-headline-of current-node))))))
|
|
|
|
(test depth-of
|
|
(let* ((test-org (sextant:make-document-from-string test-org-1))
|
|
(first-node (next-of test-org)))
|
|
(is (= 0 (depth-of first-node)))
|
|
(let* ((first-headline (next-headline-of first-node))
|
|
(line-1 (next-of first-headline)))
|
|
(is (= 0 (depth-of first-headline)))
|
|
(is (= 1 (depth-of line-1))))))
|
|
|
|
(test path-of
|
|
(with-test-org-2
|
|
(is (equal (list first-node) (path-of first-node)))
|
|
(is (equal (list first-node second-node) (path-of second-node)))
|
|
(is (equal (list first-node second-node third-node) (path-of third-node)))
|
|
(is (equal (list first-node fourth-node fifth-node) (path-of fifth-node)))))
|
|
|
|
(test count-nodes
|
|
(with-test-org-1
|
|
(is (= 0 (count-nodes line-2 line-2)))
|
|
(is (= 1 (count-nodes preamble-1 preamble-2)))
|
|
(is (= 3 (count-nodes header-2 header-3)))
|
|
(is (= 9 (count-nodes preamble-1 line-5)))
|
|
(is (null (count-nodes line-4 line-1)))))
|
|
|
|
(test visibility-1
|
|
(with-test-org-1
|
|
(collapse-node header-2)
|
|
(is (equal "preamble 1
|
|
preamble 2
|
|
* header 1
|
|
line 1
|
|
line 2
|
|
** header 2
|
|
* header 3
|
|
line 5
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(collapse-node header-1)
|
|
(is (null (node-visible-p line-1)))
|
|
(is (equal "preamble 1
|
|
preamble 2
|
|
* header 1
|
|
* header 3
|
|
line 5
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(expand-node header-2)
|
|
(is (equal "preamble 1
|
|
preamble 2
|
|
* header 1
|
|
line 3
|
|
line 4
|
|
* header 3
|
|
line 5
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(collapse-node header-3)
|
|
(is (equal "preamble 1
|
|
preamble 2
|
|
* header 1
|
|
line 3
|
|
line 4
|
|
* header 3
|
|
" (with-output-to-string (str) (org-print test-org str t))))))
|
|
|
|
(test visibility-2
|
|
(with-test-org-2
|
|
(collapse-node second-node)
|
|
(is (equal "* header 1
|
|
** sub header 1
|
|
** sub header 2
|
|
**** sub sub sub header 1
|
|
*** sub sub header 2
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(collapse-node fourth-node)
|
|
(is (equal "* header 1
|
|
** sub header 1
|
|
** sub header 2
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(collapse-node first-node)
|
|
(is (equal "* header 1
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(expand-node first-node)
|
|
(is (equal "* header 1
|
|
** sub header 1
|
|
** sub header 2
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(expand-node first-node t)
|
|
(is (equal "* header 1
|
|
** sub header 1
|
|
*** sub sub header 1
|
|
** sub header 2
|
|
**** sub sub sub header 1
|
|
*** sub sub header 2
|
|
" (with-output-to-string (str) (org-print test-org str t))))
|
|
(collapse-node first-node)
|
|
(ensure-node-visible fifth-node)
|
|
(is (equal "* header 1
|
|
** sub header 1
|
|
** sub header 2
|
|
**** sub sub sub header 1
|
|
*** sub sub header 2
|
|
" (with-output-to-string (str) (org-print test-org str t))))))
|
|
|
|
(def-suite cursor :in all-tests)
|
|
(in-suite cursor)
|
|
|
|
(defmacro check-cursor (cursor node index visual-index)
|
|
(once-only (cursor)
|
|
`(progn
|
|
(is (eq ,node (cursor-node ,cursor)))
|
|
(is (eq ,index (cursor-index ,cursor)))
|
|
(is (eq ,visual-index (visual-index ,cursor))))))
|
|
|
|
(defmacro check-visible-cursor (cursor node index visual-index)
|
|
(once-only (cursor)
|
|
`(progn
|
|
(is (eq ,node (visible-node ,cursor)))
|
|
(is (eq ,index (visible-index ,cursor)))
|
|
(is (eq ,visual-index (visual-index ,cursor))))))
|
|
|
|
(test next-previous-node
|
|
(with-test-org-1
|
|
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
|
(check-cursor cursor preamble-1 0 0)
|
|
(check-visible-cursor cursor preamble-1 0 0)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor preamble-2 1 1)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor line-1 3 3)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor line-2 4 4)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-2 5 5)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor line-3 6 6)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor line-4 7 7)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-3 8 8)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor line-5 9 9)
|
|
(is (null (next-node cursor)))
|
|
(dotimes (i 9)
|
|
(setf cursor (previous-node cursor)))
|
|
(check-visible-cursor cursor preamble-1 0 0)
|
|
(is (null (previous-node cursor))))))
|
|
|
|
(test next-previous-headline
|
|
(with-test-org-1
|
|
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
|
(setf cursor (next-headline cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(setf cursor (next-headline cursor))
|
|
(check-visible-cursor cursor header-2 5 5)
|
|
(setf cursor (next-headline cursor))
|
|
(check-visible-cursor cursor header-3 8 8)
|
|
(is (null (next-headline cursor)))
|
|
(setf cursor (previous-headline cursor))
|
|
(check-visible-cursor cursor header-2 5 5)
|
|
(setf cursor (previous-headline cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(is (null (previous-headline cursor))))))
|
|
|
|
(test next-previous-visible-node
|
|
(with-test-org-1
|
|
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
|
(collapse-node header-1)
|
|
(setf cursor (next-node (next-node cursor)))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(setf cursor (next-visible-node cursor))
|
|
(check-visible-cursor cursor header-3 8 3)
|
|
(check-cursor cursor header-3 8 3)
|
|
(expand-node header-1)
|
|
(setf cursor (previous-visible-node cursor))
|
|
(check-visible-cursor cursor header-2 5 2)
|
|
(check-cursor cursor header-2 5 2)
|
|
(setf cursor (previous-visible-node cursor))
|
|
(check-visible-cursor cursor line-2 4 1))))
|
|
|
|
(test next-previous-hidden-node
|
|
(with-test-org-1
|
|
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
|
(collapse-node header-1)
|
|
(setf cursor (next-node (next-node cursor)))
|
|
(check-cursor cursor header-1 2 2)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(check-cursor cursor line-1 3 2)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(check-cursor cursor line-2 4 2)
|
|
(setf cursor (next-node cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(check-cursor cursor header-2 5 2)
|
|
(setf cursor (next-headline cursor))
|
|
(check-visible-cursor cursor header-3 8 3)
|
|
(check-cursor cursor header-3 8 3)
|
|
(setf cursor (previous-node cursor))
|
|
(check-visible-cursor cursor header-1 2 2)
|
|
(check-cursor cursor line-4 7 2)
|
|
(expand-node header-2)
|
|
(setf cursor (previous-node cursor))
|
|
(check-visible-cursor cursor line-3 6 1)
|
|
(check-cursor cursor line-3 6 1))))
|
|
|
|
(test goto-index
|
|
(with-test-org-1
|
|
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
|
(setf cursor (goto-index cursor 4))
|
|
(check-cursor cursor line-2 4 4)
|
|
(setf cursor (goto-index cursor 9))
|
|
(check-cursor cursor line-5 9 9)
|
|
(setf cursor (goto-index cursor 0))
|
|
(check-cursor cursor preamble-1 0 0)
|
|
(is (null (goto-index cursor 10))))))
|
|
|
|
(run! 'all-tests)
|