sfos/harbour-sextant
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement expand/collapse-node functions

Browse source 
Additionally make visibility a first-class slot of org-headline
This commit is contained in:
Renaud Casenave-Péré 2023-07-09 23:04:34 +02:00
parent 7a80b4ea1e
commit ddc203a132
2 changed files with 110 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

63
lisp/local-projects/sextant/org/nodes.lisp
View file

@ -26,6 +26,9 @@
#:node-visible-p
#:count-nodes
#:count-visible-nodes
#:ensure-node-visible
#:expand-node
#:collapse-node
#:compare-nodes
#:swap-nodes
#:append-node
@ -69,6 +72,11 @@
:accessor depth-of
:initform 0
:documentation "The depth of this headline.")
(visibility :initarg :visibility
:type keyword
:accessor visibility-of
:initform :expanded
:documentation "The collapsed/expanded state of this headline.")
(title :initarg :title
:type string
:accessor title-of
@ -92,7 +100,7 @@
(make-instance 'org-line :raw-text raw-text :line-ending line-ending))
(defun make-org-headline (depth title raw-text line-ending)
(make-instance 'org-headline :depth depth :title title
(make-instance 'org-headline :depth depth :visibility :expanded :title title
:raw-text raw-text :line-ending line-ending
:properties (list :visibility :expanded)))
@ -149,6 +157,12 @@
(defmethod title-of ((node org-line))
(raw-text-of node))
(defun collapsedp (node)
(eq (visibility-of node) :collapsed))
(defun expandedp (node)
(eq (visibility-of node) :expanded))
(defmethod previous-visible-of (node))
@ -174,7 +188,7 @@
(next-of node))
(defmethod next-visible-of ((node org-headline))
(if (eq (property-of node :visibility) :expanded)
(if (expandedp node)
(next-of node)
(next-visible-headline-of node)))
@ -196,7 +210,7 @@
(defun node-visible-p (node)
(let ((headline (headline-of node)))
(or (not headline) (eq (property-of headline :visibility) :expanded))))
(or (not headline) (expandedp headline))))
(defun count-nodes (begin end)
(if (eq begin end)
@ -215,6 +229,47 @@
count n into step
until (or (null n) (eq n end))
finally (return (and (eq n end) step)))))
(defun ensure-node-visible (node)
(unless (node-visible-p node)
(let* ((root (visible-headline-of node))
(headlines (cons root (path-of node root))))
(mapc (lambda (h) (setf (visibility-of h) :expanded)) headlines))))
(defgeneric expand-node (node &optional recursep))
(defmethod expand-node ((node org-node) &optional recursep)
(declare (ignore node recursep)))
(defmethod expand-node ((node org-headline) &optional recursep)
(setf (visibility-of node) :expanded)
(when recursep
(let ((headlines (loop with depth = (depth-of node)
for h = (next-headline-of node) then (next-headline-of h)
until (or (null h) (<= (depth-of h) depth))
when (collapsedp h)
collect h)))
(mapc (lambda (h) (setf (visibility-of h) :expanded)) headlines))))
(defgeneric collapse-node (node))
(defmethod collapse-node ((node org-node))
(declare (ignore node)))
(defmethod collapse-node ((node org-headline))
(let ((headlines (reverse (cons node (loop with depth = (depth-of node)
for h = (next-visible-headline-of node) then (next-visible-headline-of h)
until (or (null h) (<= (depth-of h) depth))
when (expandedp h)
collect h)))))
(mapc (lambda (h) (setf (visibility-of h) :collapsed)) headlines)))
(defgeneric compare-nodes (old new))
@ -315,8 +370,6 @@
(setf (next-headline-of prev-headline) next
(previous-headline-of next) prev-headline)))))
(defun link-nodes (&rest nodes)
(loop for n on nodes
while (second n)

67
tests.lisp
View file

@ -126,9 +126,9 @@ line 5
(is (= 9 (count-nodes preamble-1 line-5)))
(is (null (count-nodes line-4 line-1)))))
(test visibility
(test visibility-1
(with-test-org-1
(setf (property-of header-2 :visibility) :collapsed)
(collapse-node header-2)
(is (equal "preamble 1
preamble 2
* header 1
@ -138,7 +138,7 @@ line 2
* header 3
line 5
" (with-output-to-string (str) (org-print test-org str t))))
(setf (property-of header-1 :visibility) :collapsed)
(collapse-node header-1)
(is (null (node-visible-p line-1)))
(is (equal "preamble 1
preamble 2
@ -146,7 +146,7 @@ preamble 2
* header 3
line 5
" (with-output-to-string (str) (org-print test-org str t))))
(setf (property-of header-2 :visibility) :expanded)
(expand-node header-2)
(is (equal "preamble 1
preamble 2
* header 1
@ -155,7 +155,7 @@ line 4
* header 3
line 5
" (with-output-to-string (str) (org-print test-org str t))))
(setf (property-of header-3 :visibility) :collapsed)
(collapse-node header-3)
(is (equal "preamble 1
preamble 2
* header 1
@ -164,6 +164,45 @@ 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)
@ -183,7 +222,7 @@ line 4
(test next-previous-node
(with-test-org-1
(let ((cursor (make-cursor preamble-1 0 0)))
(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))
@ -212,7 +251,7 @@ line 4
(test next-previous-headline
(with-test-org-1
(let ((cursor (make-cursor preamble-1 0 0)))
(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))
@ -228,15 +267,14 @@ line 4
(test next-previous-visible-node
(with-test-org-1
(let ((cursor (make-cursor preamble-1 0 0)))
(setf (property-of header-2 :visibility) :collapsed)
(setf (property-of header-1 :visibility) :collapsed)
(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)
(setf (property-of header-1 :visibility) :expanded)
(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)
@ -245,9 +283,8 @@ line 4
(test next-previous-hidden-node
(with-test-org-1
(let ((cursor (make-cursor preamble-1 0 0)))
(setf (property-of header-2 :visibility) :collapsed)
(setf (property-of header-1 :visibility) :collapsed)
(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))
@ -265,7 +302,7 @@ line 4
(setf cursor (previous-node cursor))
(check-visible-cursor cursor header-1 2 2)
(check-cursor cursor line-4 7 2)
(setf (property-of header-2 :visibility) :expanded)
(expand-node header-2)
(setf cursor (previous-node cursor))
(check-visible-cursor cursor line-3 6 1)
(check-cursor cursor line-3 6 1))))