Restart from scratch: better API for nodes and cursor

lisp/local-projects/sextant/org/all.lisp

@@ -2,5 +2,6 @@
   (:nicknames :org)
   (:use-reexport
    :sextant/org/nodes
+   :sextant/org/cursor
    :sextant/org/parser
    :sextant/org/printer))

lisp/local-projects/sextant/org/cursor.lisp

@@ -0,0 +1,111 @@
+(uiop:define-package :sextant/org/cursor
+  (:use :cl :alexandria :sextant/org/nodes)
+  (:export #:make-cursor
+           #:cursor-node
+           #:cursor-index
+           #:visible-node
+           #:visible-index
+           #:visual-index
+           #:move-cursor
+           #:previous-visible-node
+           #:previous-visible-headline
+           #:previous-node
+           #:previous-headline
+           #:next-visible-node
+           #:next-visible-headline
+           #:next-node
+           #:next-headline))
+(in-package :sextant/org/cursor)
+
+(defstruct (cursor (:constructor make-cursor (node index visual-index)))
+  (node nil)
+  (index 0 :type number)
+  (visual-index 0 :type number))
+
+(defun visual-index (cursor) (cursor-visual-index cursor))
+
+(defun visible-node (cursor)
+  (let ((node (cursor-node cursor)))
+    (if (node-visible-p node)
+        node
+        (visible-headline-of node))))
+
+(defun visible-index (cursor)
+  (let ((node (cursor-node cursor)))
+    (if (node-visible-p node)
+        (cursor-index cursor)
+        (- (cursor-index cursor) (count-nodes (visible-headline-of node) node)))))
+
+
+
+(defgeneric node-index (prev next))
+
+(defmethod node-index ((prev cursor) (next org-node))
+  (+ (cursor-index prev) (count-nodes (cursor-node prev) next)))
+
+(defmethod node-index ((prev org-node) (next cursor))
+  (- (cursor-index next) (count-nodes prev (cursor-node next))))
+
+(defgeneric node-visual-index (prev next))
+
+(defmethod node-visual-index ((prev cursor) (next org-node))
+  (+ (visual-index prev) (count-visible-nodes (visible-node prev) (if (node-visible-p next) next (visible-headline-of next)))))
+
+(defmethod node-visual-index ((prev org-node) (next cursor))
+  (- (visual-index next) (count-visible-nodes (if (node-visible-p prev) prev (visible-headline-of prev)) (visible-node next))))
+
+(defun move-cursor-< (cursor target)
+  (make-cursor target (node-index target cursor) (node-visual-index target cursor)))
+
+(defun move-cursor-> (cursor target)
+  (make-cursor target (node-index cursor target) (node-visual-index cursor target)))
+
+(defun move-cursor (cursor target direction)
+  (if (plusp direction)
+      (move-cursor-> cursor target)
+      (move-cursor-< cursor target)))
+
+
+
+(defun previous-visible-node (cursor)
+  (when-let ((target (previous-visible-of (visible-node cursor))))
+    (move-cursor-< cursor target)))
+
+(defun previous-node (cursor)
+  (when-let ((target (previous-of (cursor-node cursor))))
+    (move-cursor-< cursor target)))
+
+(defun previous-visible-headline (cursor)
+  (when-let ((target (previous-visible-headline-of cursor (visible-node cursor))))
+    (move-cursor-< cursor target)))
+
+(defgeneric %previous-headline (cursor node))
+
+(defmethod %previous-headline (cursor (node org-line))
+  (when-let ((target (headline-of node)))
+    (move-cursor-< cursor target)))
+
+(defmethod %previous-headline (cursor (node org-headline))
+  (when-let ((target (previous-headline-of node)))
+    (move-cursor-< cursor target)))
+
+(defun previous-headline (cursor)
+  (%previous-headline cursor (cursor-node cursor)))
+
+
+
+(defun next-visible-node (cursor)
+  (when-let ((target (next-visible-of (visible-node cursor))))
+    (move-cursor-> cursor target)))
+
+(defun next-node (cursor)
+  (when-let ((target (next-of (cursor-node cursor))))
+    (move-cursor-> cursor target)))
+
+(defun next-visible-headline (cursor)
+  (when-let ((target (next-visible-headline-of (visible-node cursor))))
+    (move-cursor-> cursor target)))
+
+(defun next-headline (cursor)
+  (when-let ((target (next-headline-of (cursor-node cursor))))
+    (move-cursor-> cursor target)))

lisp/local-projects/sextant/org/nodes.lisp

@@ -1,5 +1,5 @@
 (uiop:define-package :sextant/org/nodes
-  (:use :cl)
+  (:use :cl :alexandria)
   (:export #:org-node
            #:org-document
            #:org-line
@@ -17,12 +17,19 @@
            #:make-org-headline
            #:property-of
            #:headline-of
-           #:node-path
+           #:visible-headline-of
+           #:previous-visible-of
+           #:previous-visible-headline-of
+           #:next-visible-of
+           #:next-visible-headline-of
+           #:path-of
            #:node-visible-p
+           #:count-nodes
+           #:count-visible-nodes
+           #:compare-nodes
+           #:swap-nodes
            #:append-node
-           #:process-last-node
-           #:collect-nodes
-           #:replace-node))
+           #:link-nodes))
 (in-package :sextant/org/nodes)
 
 (defclass org-node ()
@@ -104,9 +111,11 @@
   (with-slots (properties) node
     (setf (getf properties key) new-value)))
 
+
+
 (defgeneric headline-of (node))
 
-(defmethod headline-of ((node org-line))
+(defmethod headline-of ((node org-node))
   (loop for prev = (previous-of node) then (previous-of prev)
         while (and prev (not (subtypep (type-of prev) 'org-headline)))
         finally (return prev)))
@@ -116,106 +125,199 @@
         while (and prev (>= (depth-of prev) (depth-of node)))
         finally (return prev)))
 
-(defmethod next-headline-of ((node org-line))
+(defun visible-headline-of (node)
+  (loop for h = (headline-of node) then (headline-of h)
+        until (or (null h) (node-visible-p h))
+        finally (progn
+                  (assert h)
+                  (return h))))
+
+
+
+(defmethod depth-of ((node org-node))
+  (let ((headline (headline-of node)))
+    (if headline (1+ (depth-of headline)) 0)))
+
+(defmethod previous-headline-of ((node org-node))
+  (headline-of node))
+
+(defmethod next-headline-of ((node org-node))
   (loop for next = (next-of node) then (next-of next)
         while (and next (not (subtypep (type-of next) 'org-headline)))
         finally (return next)))
 
 (defmethod title-of ((node org-line))
-  "")
+  (raw-text-of node))
 
 
 
-(defun node-path (node &optional parent)
-  (let (path (list node))
-    (loop for h = (headline-of node) then (headline-of node)
-          until (or (null h) (eq h parent))
+(defmethod previous-visible-of (node))
+
+(defmethod previous-visible-of ((node org-node))
+  (previous-of node))
+
+(defmethod previous-visible-of ((node org-headline))
+  (when-let ((prev (previous-of node)))
+    (if (node-visible-p prev)
+        prev
+        (visible-headline-of prev))))
+
+(defun previous-visible-headline-of (node)
+  (when-let ((prev (previous-headline-of node)))
+    (if (node-visible-p prev)
+        prev
+        (visible-headline-of prev))))
+
+(defgeneric next-visible-of (node))
+
+(defmethod next-visible-of ((node org-node))
+  (next-of node))
+
+(defmethod next-visible-of ((node org-headline))
+  (if (eq (property-of node :visibility) :expanded)
+      (next-of node)
+      (next-visible-headline-of node)))
+
+(defun next-visible-headline-of (node)
+  (loop for h = (next-headline-of node) then (next-headline-of h)
+        until (or (null h) (node-visible-p h))
+        finally (return h)))
+
+
+
+(defun path-of (node &optional root)
+  (let ((path (list node)))
+    (loop for h = (headline-of node) then (headline-of h)
+          until (or (null h) (eq h root))
           do (push h path)
           finally (progn
-                    (assert (eq h parent))
-                    path))))
+                    (assert (eq h root))
+                    (return path)))))
 
 (defun node-visible-p (node)
   (let ((headline (headline-of node)))
     (or (not headline) (eq (property-of headline :visibility) :expanded))))
 
+(defun count-nodes (begin end)
+  (if (eq begin end)
+      0
+      (loop for n = (next-of begin) then (next-of n)
+            count n into step
+            until (or (null n) (eq n end))
+            finally (return (and (eq n end) step)))))
+
+(defun count-visible-nodes (begin end)
+  (assert (node-visible-p begin))
+  (assert (node-visible-p end))
+  (if (eq begin end)
+      0
+      (loop for n = (next-visible-of begin) then (next-visible-of n)
+            count n into step
+            until (or (null n) (eq n end))
+            finally (return (and (eq n end) step)))))
 
 
-(defgeneric replace-node (old new))
+(defgeneric compare-nodes (old new))
 
-(defun replace-simple-node (old new)
+(defmethod compare-nodes ((old org-line) (new org-line))
+  :same)
+
+(defmethod compare-nodes ((old org-headline) (new org-headline))
+  (cond
+    ((< (depth-of old) (depth-of new)) :headline-<)
+    ((> (depth-of old) (depth-of new)) :headline->)
+    (t :depth-=)))
+
+(defmethod compare-nodes ((old org-headline) (new org-line))
+  :depth->)
+
+(defmethod compare-nodes ((old org-line) (new org-headline))
+  :depth-<)
+
+
+
+(defun %swap-nodes (old new)
   (when (previous-of old)
     (setf (previous-of new) (previous-of old)
           (next-of (previous-of old)) new))
   (when (next-of old)
     (setf (next-of new) (next-of old)
           (previous-of (next-of old)) new))
-  nil)
+  new)
 
-(defmethod replace-node ((old org-line) (new org-line))
-  (replace-simple-node old new))
+(defgeneric swap-nodes (old new))
 
-(defmethod replace-node ((old org-headline) (new org-headline))
-  (replace-simple-node old new)
-  (when (previous-headline-of old)
-    (setf (previous-headline-of new) (previous-headline-of old)
-          (next-headline-of (previous-headline-of old)) new))
-  (when (next-headline-of old)
-    (setf (next-headline-of new) (next-headline-of old)
-          (previous-headline-of (next-headline-of old)) new))
-  (setf (slot-value new 'properties) (slot-value old 'properties))
-  t)
+(defmethod swap-nodes ((old org-line) (new org-line))
+  (%swap-nodes old new))
 
-(defmethod replace-node ((old org-headline) (new org-line))
-  (replace-simple-node old new)
-  (when (previous-headline-of old)
-    (setf (next-headline-of (previous-headline-of old)) (next-headline-of old)))
-  (when (next-headline-of old)
-    (setf (previous-headline-of (next-headline-of old)) (previous-headline-of old)))
-  t)
+(defmethod swap-nodes ((old org-headline) (new org-headline))
+  (prog1
+      (%swap-nodes old new)
+    (when (previous-headline-of old)
+      (setf (previous-headline-of new) (previous-headline-of old)
+            (next-headline-of (previous-headline-of old)) new))
+    (when (next-headline-of old)
+      (setf (next-headline-of new) (next-headline-of old)
+            (previous-headline-of (next-headline-of old)) new))
+    (setf (slot-value new 'properties) (slot-value old 'properties))))
 
-(defmethod replace-node ((old org-line) (new org-headline))
-  (replace-simple-node old new)
-  (let ((headline (headline-of old)))
-    (if headline
-        (progn
-          (when (next-headline-of headline)
-            (setf (next-headline-of new) (next-headline-of headline)
-                  (previous-headline-of (next-headline-of headline)) new))
-          (setf (next-headline-of headline) new
-                (previous-headline-of new) headline))
-        (let ((headline (next-headline-of old)))
-          (when headline
-            (setf (previous-headline-of headline) new
-                  (next-headline-of new) headline))))
-    t))
+(defmethod swap-nodes ((old org-headline) (new org-line))
+  (prog1
+      (%swap-nodes old new)
+    (when (previous-headline-of old)
+      (setf (next-headline-of (previous-headline-of old)) (next-headline-of old)))
+    (when (next-headline-of old)
+      (setf (previous-headline-of (next-headline-of old)) (previous-headline-of old)))))
+
+(defmethod swap-nodes ((old org-line) (new org-headline))
+  (prog1
+      (%swap-nodes old new)
+    (let ((headline (headline-of old)))
+      (if headline
+          (progn
+            (when (next-headline-of headline)
+              (setf (next-headline-of new) (next-headline-of headline)
+                    (previous-headline-of (next-headline-of headline)) new))
+            (setf (next-headline-of headline) new
+                  (previous-headline-of new) headline))
+          (let ((headline (next-headline-of old)))
+            (when headline
+              (setf (previous-headline-of headline) new
+                    (next-headline-of new) headline)))))))
 
 
 
+(defun %append-node (node next)
+  (assert (null (next-of node)))
+  (assert (null (previous-of next)))
+  (assert (null (next-of next)))
+  (setf (next-of node) next
+        (previous-of next) node)
+  node)
+
 (defgeneric append-node (node next))
-(defgeneric process-last-node (node))
 
-(let (current-headline)
-  (defmethod append-node ((node org-line) next)
-    (setf (next-of node) next
-          (previous-of next) node)
-    node)
+(defmethod append-node ((node org-line) (next org-line))
+ (%append-node node next))
 
-  (defmethod append-node :before ((node org-headline) next)
-    (when current-headline
-      (setf (next-headline-of current-headline) node
-            (previous-headline-of node) current-headline))
-    (setf current-headline node))
+(defmethod append-node ((node org-headline) (next org-headline))
+  (prog1
+      (%append-node node next)
+    (setf (next-headline-of node) next
+          (previous-headline-of next) node)))
 
-  (defmethod process-last-node ((node org-line))
-    (setf current-headline nil))
+(defmethod append-node ((node org-line) (next org-headline))
+  (prog1
+      (%append-node node next)
+    (let ((prev-headline (headline-of node)))
+      (when prev-headline
+        (assert (null (next-headline-of prev-headline)))
+        (setf (next-headline-of prev-headline) next
+              (previous-headline-of next) prev-headline)))))
 
-  (defmethod process-last-node :before ((node org-headline))
-    (when current-headline
-      (setf (next-headline-of current-headline) node
-            (previous-headline-of node) current-headline))))
+
 
-(defun collect-nodes (&rest nodes)
+(defun link-nodes (&rest nodes)
   (loop for n on nodes
         while (second n)
         do (append-node (first n) (second n)))

lisp/local-projects/sextant/org/parser.lisp

@@ -10,8 +10,8 @@
   (let ((str (etypecase spec
                (string spec)
                ((or pathname stream) (read-file-into-string spec)))))
-    (time (lexy::parse-document str))))
+    (lexy::parse-document str)))
 
 (defun parse-node (node)
-  (time (lexy::parse-node (with-output-to-string (stream)
-                            (org-print node stream)))))
+  (lexy::parse-node (with-output-to-string (stream)
+                      (org-print node stream))))

lisp/local-projects/sextant/sextant.asd

@@ -8,9 +8,10 @@
   :depends-on #.(append (uiop:read-file-form (merge-pathnames #p"dependencies.sexp" (or *load-pathname* *compile-file-pathname*)))
                         '("sextant/org/all")
                         '("sextant/options/all")
-                        '("sextant/models/all"))
+                        ;; '("sextant/models/all")
+                        )
   :components ((:file "sextant")))
 
 (register-system-packages "sextant/org/all" '(:org))
 (register-system-packages "sextant/options/all" '(:options))
-(register-system-packages "sextant/models/all" '(:models))
+;; (register-system-packages "sextant/models/all" '(:models))

lisp/local-projects/sextant/sextant.lisp

@@ -1,11 +1,14 @@
 (uiop:define-package :sextant
-  (:use :cl :eql :org :options :models)
+  (:use :cl :eql :org :options ;; :models
+        )
   (:export #:start-slynk
            #:stop-slynk
            #:slynkp
            #:refresh-agenda-files
            #:open-file
            #:close-file
+           #:make-document-from-string
+           #:open-from-string
            #:delete-file*
            #:start
            #:reload-qml
@@ -62,7 +65,20 @@
     (let ((pathname (if filepath (parse-namestring filepath) currently-open-file)))
       (when pathname
         (save-commands pathname)
-        (setf currently-open-file nil)))))
+        (setf currently-open-file nil))))
+
+  (defun make-document-from-string (str)
+    (if (> (length str) 0)
+        (parse-document str)
+        (make-org-document (make-org-line "" ""))))
+
+  (defun open-from-string (str)
+    (let ((org-document (if (> (length str) 0)
+                            (parse-document str)
+                            (make-org-document (make-org-line "" "")))))
+      (make-org-model nil org-document)
+      (initialize-commands nil)
+      nil)))
 
 (defun delete-file* (filepath)
   (let ((pathname (parse-namestring filepath)))

sextant.pro

@@ -21,14 +21,15 @@ LISP_FILES = make.lisp \
     lisp/local-projects/sextant/models/org-model.lisp \
     lisp/local-projects/sextant/models/files-model.lisp \
     lisp/local-projects/sextant/models/commands.lisp \
+    lisp/local-projects/sextant/org/nodes.lisp \
+    lisp/local-projects/sextant/org/cursor.lisp \
+    lisp/local-projects/sextant/org/parser.lisp \
+    lisp/local-projects/sextant/org/printer.lisp \
+    lisp/local-projects/sextant/org/all.lisp \
     lisp/local-projects/sextant/models/actions.lisp \
     lisp/local-projects/sextant/models/all.lisp \
     lisp/local-projects/sextant/sextant.lisp \
     lisp/local-projects/sextant/sextant.asd \
-    lisp/local-projects/sextant/org/parser.lisp \
-    lisp/local-projects/sextant/org/printer.lisp \
-    lisp/local-projects/sextant/org/nodes.lisp \
-    lisp/local-projects/sextant/org/all.lisp
 
 lisp.output = libsextant.a
 lisp.commands = $$PWD/sextant-bootstrap -platform minimal -make

src/parser/node_sink.hh

@@ -37,7 +37,6 @@ namespace sextant
 
             cl_object&& finish() &&
             {
-                ast_funcall("PROCESS-LAST-NODE", _tail);
                 return LEXY_MOV(_head);
             }
         };
@@ -59,7 +58,7 @@ namespace sextant
             template <typename... Args>
             constexpr cl_object operator()(Args&&... args) const
             {
-                return ast_funcall("COLLECT-NODES", args...);
+                return ast_funcall("LINK-NODES", args...);
             }
 
             auto sink() const