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

Introduce a la emacs ‘cursor’ concept

Browse source
This commit is contained in:
Renaud Casenave-Péré 2023-01-18 22:20:03 +01:00
parent a71cd29bb0
commit 10c872f461
2 changed files with 122 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lisp/local-projects/sextant/models/commands.lisp
View file

@ -90,7 +90,7 @@
(new-node (parse-node node)))
(if (or (replace-data node new-node) force)
(refresh-data index
(nth-value 1 (goto-end-section)))
(progn (goto-end-section) (current-index)))
(refresh-data index))
new-node))
@ -111,8 +111,7 @@
(if update-ui
(progn
(removing-rows ((1+ (index-of command)))
(relink-nodes node next-next)
(dec-nodes-count))
(relink-nodes node next-next))
(reparse-node (index-of command) (subtypep (type-of next) 'org-headline)))
(progn
(relink-nodes node next-next)
@ -133,8 +132,7 @@
(if update-ui
(progn
(inserting-rows ((1+ (index-of command)))
(relink-nodes node next new-node)
(inc-nodes-count))
(relink-nodes node next new-node))
(reparse-node (index-of command))
(reparse-node (1+ (index-of command))))
(progn

174
lisp/local-projects/sextant/models/org-model.lisp
View file

@ -24,11 +24,7 @@
+last-item-role+)
(defvar *current-pathname* nil)
(defvar *org-document* nil)
(defvar *current-headline* nil)
(defvar *current-node* nil)
(defvar *current-index* 0)
(defvar *nodes-count* 0)
(defvar *org-model* nil)
@ -36,6 +32,32 @@
(defvar *cursor* (list nil nil 0))
(defun current-node () (nth 0 *cursor*))
(defun current-headline () (nth 1 *cursor*))
(defun current-index () (nth 2 *cursor*))
(defun move-cursor (node headline step)
(setf *cursor* (list node headline (+ (current-index) step))))
(defun set-current-node (node) (setf (nth 0 *cursor*) node))
(defun set-current-headline (node) (setf (nth 1 *cursor*) node))
(defun set-current-index (index) (setf (nth 2 *cursor*) index))
(defun inc-current-index (&optional (step 1)) (incf (nth 2 *cursor*) step))
(defun dec-current-index (&optional (step 1)) (decf (nth 2 *cursor*) step))
(defvar *saved-cursors* nil)
(defmacro save-excursion (&body body)
`(prog2
(push (copy-seq *cursor*) *saved-cursors*)
(progn ,@body)
(pop *saved-cursors*)))
(defun current-pathname () *current-pathname*)
(defun org-document () *org-document*)
@ -53,12 +75,12 @@
(defun replace-data (node new-node)
(prog1
(replace-node node new-node)
(when (eq *current-node* node)
(setf *current-node* new-node))
(when (eq (current-node) node)
(set-current-node new-node))
(when (subtypep (type-of new-node) 'org-headline)
(setf *current-headline* new-node))
(when (eq *current-headline* node)
(setf *current-headline* (if (subtypep (type-of new-node) 'org-headline)
(set-current-headline new-node))
(when (eq (current-headline) node)
(set-current-headline (if (subtypep (type-of new-node) 'org-headline)
new-node
(headline-of new-node))))))
@ -73,6 +95,7 @@
(|beginRemoveRows| sextant/models/org-model::*org-model*
sextant/models/org-model::*empty-model-index* ,start ,end)
,@body
(decf sextant/models/org-model::*nodes-count* (1+ (- ,end ,start)))
(|endRemoveRows| sextant/models/org-model::*org-model*))))
(defmacro inserting-rows ((start &optional (end start)) &body body)
@ -81,6 +104,7 @@
(|beginInsertRows| sextant/models/org-model::*org-model*
sextant/models/org-model::*empty-model-index* ,start ,end)
,@body
(incf sextant/models/org-model::*nodes-count* (1+ (- ,end ,start)))
(|endInsertRows| sextant/models/org-model::*org-model*))))
@ -88,61 +112,101 @@
(defgeneric node-depth (node))
(defmethod node-depth ((node org-line))
(if *current-headline*
(1+ (depth-of *current-headline*))
(if (current-headline)
(1+ (depth-of (current-headline)))
0))
(defmethod node-depth ((node org-headline))
(depth-of node))
(defun previous-node (node)
(let ((prev (previous-of node)))
(assert prev)
(when (subtypep (type-of node) 'org-headline)
(setf *current-headline* (previous-headline-of node)))
prev))
(defun previous-visible-headline (headline)
(let ((prev (previous-headline-of headline)))
(if (or (null prev) (<= (depth-of prev) (depth-of headline)))
prev
(loop with depth = (depth-of prev)
for h = (previous-headline-of prev) then (previous-headline-of h)
until (or (null h)
(and (< (depth-of h) depth)
(eq (property-of h :visibility) :expanded)))
when (< (depth-of h) depth)
do (setf prev h
depth (depth-of h))
finally (return prev)))))
(defun next-node (node)
(defun %%previous-node (node headline)
(values (previous-of node)
(if (eq node headline)
(previous-headline-of headline)
headline)))
(defgeneric %previous-node (node headline))
(defmethod %previous-node ((node org-line) headline)
(%%previous-node node headline))
(defmethod %previous-node ((node org-headline) headline)
(assert (eq node headline))
(if (null (previous-headline-of node))
(%%previous-node node node)
(ecase (property-of (previous-headline-of node) :visibility)
(:expanded (%%previous-node node node))
(:collapsed (let ((prev (previous-visible-headline node)))
(values prev prev))))))
(defun previous-node ()
(multiple-value-bind (node headline) (%previous-node (current-node) (current-headline))
(when node
(move-cursor node headline -1))))
(defun %%next-node (node headline)
(let ((next (next-of node)))
(assert next)
(when (subtypep (type-of next) 'org-headline)
(setf *current-headline* next))
next))
(values next
(if (subtypep (type-of next) 'org-headline)
next
headline))))
(defun step-to-node (from pred stepper)
(assert from)
(loop until (funcall pred from)
do (setf from (funcall stepper from))
finally (return from)))
(defgeneric %next-node (node headline))
(defmethod %next-node ((node org-line) headline)
(%%next-node node headline))
(defmethod %next-node ((node org-headline) headline)
(assert (eq node headline))
(ecase (property-of node :visibility)
(:expanded (%%next-node node headline))
(:collapsed (let ((depth (depth-of node)))
(loop for n = (next-headline-of node) then (next-headline-of n)
until (or (null n) (<= (depth-of n) depth))
finally (return (values n n)))))))
(defun next-node ()
(multiple-value-bind (node headline) (%next-node (current-node) (current-headline))
(when node
(move-cursor node headline 1))))
(defun goto-index (index)
(unless (= index *current-index*)
(let* ((step (- index *current-index*))
(stepper (if (< step 0) #'previous-node #'next-node))
(count (abs step)))
(setf *current-node* (step-to-node *current-node*
(lambda (node)
(declare (ignore node))
(prog1
(= count 0)
(decf count)))
stepper)
*current-index* index)))
(values *current-node* *current-index* *current-headline*))
(assert (>= index 0))
(assert (< index *nodes-count*))
(unless (= index (current-index))
(let* ((step (- index (current-index))))
(if (< step 0)
(loop do (progn
(previous-node)
(incf step))
until (= step 0))
(loop do (progn
(next-node)
(decf step))
until (= step 0)))))
(values-list *cursor*))
(defun goto-end-section ()
(let ((depth (and *current-headline* (depth-of *current-headline*)))
(step 0))
(setf *current-node* (step-to-node *current-node*
(lambda (node)
(or (let ((next (next-of node)))
(or (null next)
(and (subtypep (type-of next) 'org-headline)
(or (null depth) (<= (depth-of next) depth)))))
(not (incf step))))
#'next-node))
(incf *current-index* step)
(values *current-node* *current-index* *current-headline*)))
(let ((depth (and (current-headline) (depth-of (current-headline)))))
(loop for (n h i) = (next-node) then (next-node)
until (or (null n) (<= (node-depth n) depth)))
(if (<= (node-depth (current-node)) depth)
(previous-node)
*cursor*)))
@ -187,9 +251,9 @@
(setf *current-pathname* pathname)
(|beginResetModel| *org-model*)
(setf *org-document* org-document
*current-node* (next-of org-document)
*current-index* 0
*nodes-count* (loop for node = (next-of org-document) then (next-of node)
while node count node))
(setf *current-headline* (and (subtypep (type-of *current-node*) 'org-headline) *current-node*))
(let* ((node (next-of org-document))
(headline (and (subtypep (type-of node) 'org-headline) node)))
(setf *cursor* (list node headline 0)))
(|endResetModel| *org-model*))