243 lines
9.9 KiB
Common Lisp
243 lines
9.9 KiB
Common Lisp
(uiop:define-package :sextant/models/org-model
|
||
(:use :cl :eql :org :qml-lisp :s-base64 :alexandria
|
||
:sextant/models/utils
|
||
:sextant/models/cursor)
|
||
(:export #:inc-visual-nodes-count
|
||
#:dec-visual-nodes-count
|
||
#:refresh-data
|
||
#:hiding-rows
|
||
#:showing-rows
|
||
#:remove-rows
|
||
#:removing-rows
|
||
#:insert-rows
|
||
#:inserting-rows
|
||
#:reparse-node
|
||
#:goto-visual-index
|
||
#:goto-end-visible-section
|
||
#:goto-index
|
||
#:ensure-visible
|
||
#:expand-headline
|
||
#:collapse-headline
|
||
#:make-org-model))
|
||
(in-package :sextant/models/org-model)
|
||
|
||
(define-roles #.|Qt.UserRole|
|
||
+nodetype-role+
|
||
+rawtext-role+
|
||
+headline-depth-role+
|
||
+depth-role+
|
||
+title-role+
|
||
+last-item-role+)
|
||
|
||
(defvar *current-pathname* nil)
|
||
(defvar *visual-nodes-count* 0)
|
||
|
||
(defvar *org-model* nil)
|
||
(defvar *empty-model-index* (qnew "QModelIndex"))
|
||
|
||
|
||
|
||
(defun model-index (index)
|
||
(|index| *org-model* index))
|
||
|
||
(defun inc-visual-nodes-count (&optional (count 1))
|
||
(incf *visual-nodes-count* count))
|
||
|
||
(defun dec-visual-nodes-count (&optional (count 1))
|
||
(decf *visual-nodes-count* count))
|
||
|
||
|
||
|
||
(defun refresh-data (start &optional (end start))
|
||
(let* ((start-index (model-index start))
|
||
(end-index (if (= end start) start-index (model-index end))))
|
||
(|dataChanged| *org-model* start-index end-index)))
|
||
|
||
(defun reparse-node (index)
|
||
(let* ((node (goto-index index))
|
||
(new-node (parse-node node)))
|
||
(assert (node-visible-p node))
|
||
(case (compare-nodes node new-node)
|
||
(:depth->
|
||
(expand-headline)
|
||
(when (> index 0)
|
||
(ensure-visible (1- index)))
|
||
(swap-nodes node new-node)
|
||
(refresh-data index (save-excursion (nth-value 1 (goto-end-visual-section)))))
|
||
(:depth-<
|
||
(swap-nodes node new-node)
|
||
(refresh-data index (save-excursion (nth-value 1 (goto-end-visual-section))))))
|
||
(replace-cursor new-node index)
|
||
new-node))
|
||
|
||
|
||
|
||
(defun remove-rows (start count fun)
|
||
(let ((end (+ start (1- count))))
|
||
(|beginRemoveRows| *org-model* *empty-model-index* start end)
|
||
(funcall fun)
|
||
(decf *visual-nodes-count* count)
|
||
(|endRemoveRows| *org-model*)))
|
||
|
||
(defmacro removing-rows ((start &optional (count 1)) &body body)
|
||
`(sextant/models/org-model::remove-rows
|
||
,start ,count
|
||
(lambda ()
|
||
,(sextant/models/cursor::adjust-saved-cursors-before-remove start count)
|
||
,@body)))
|
||
|
||
(defmacro hiding-rows ((start &optional (count 1)) &body body)
|
||
`(sextant/models/org-model::remove-rows ,start ,count (lambda () ,@body)))
|
||
|
||
(defun insert-rows (start count fun)
|
||
(let ((end (+ start (1- count))))
|
||
(|beginInsertRows| *org-model* *empty-model-index* start end)
|
||
(funcall fun)
|
||
(incf *visual-nodes-count* count)
|
||
(|endInsertRows| *org-model*)))
|
||
|
||
(defmacro inserting-rows ((start &optional (count 1)) &body body)
|
||
`(sextant/models/org-model::insert-rows
|
||
,start ,count
|
||
(lambda ()
|
||
,(sextant/models/cursor::adjust-saved-cursors-before-insert start count)
|
||
,@body)))
|
||
|
||
(defmacro showing-rows ((start &optional (count 1)) &body body)
|
||
`(sextant/models/org-model::insert-rows ,start ,count (lambda () ,@body)))
|
||
|
||
|
||
|
||
(defun ensure-visible (index)
|
||
(let ((node (goto-index index)))
|
||
(unless (node-visible-p node)
|
||
(expand-headline (node-path node (current-headline))))))
|
||
|
||
(defun expand-headline (&optional recurse)
|
||
(assert (eq (current-visual-node) (current-node)))
|
||
(let* ((node (current-visual-node))
|
||
(depth (node-depth)))
|
||
(assert (eq node (current-visual-headline)))
|
||
(save-excursion
|
||
(if (null recurse)
|
||
(when (eq (property-of node :visibility) :collapsed)
|
||
(let ((count (save-excursion
|
||
(loop with index = (1+ (current-index))
|
||
and sub-headline-depth = nil
|
||
for n = (next-node) then (next-node)
|
||
until (or (null n) (<= (node-depth) depth))
|
||
when (eq (current-node) (current-headline))
|
||
do (setf sub-headline-depth (node-depth))
|
||
count (or (null sub-headline-depth) (= (node-depth) sub-headline-depth))))))
|
||
(showing-rows ((1+ (current-index)) count)
|
||
(setf (property-of node :visibility) :expanded))))
|
||
(let ((depth/visibility (list (cons depth (property-of node :visibility)))))
|
||
(flet ((parent-depth () (assert (not (null depth/visibility))) (car (first depth/visibility)))
|
||
(parent-collapsed-p () (assert (not (null depth/visibility))) (eq (cdr (first depth/visibility)) :collapsed))
|
||
(push-depth/visibility (depth visibility)
|
||
(assert (> depth (parent-depth)))
|
||
(push (cons depth visibility) depth/visibility))
|
||
(expand-those-headlines (index count headlines)
|
||
(assert (> count 0))
|
||
(save-excursion
|
||
(showing-rows (index count)
|
||
(loop for h in headlines
|
||
do (progn
|
||
(assert (subtypep (type-of h) 'org-headline))
|
||
(setf (property-of h :visibility) :expanded)))))))
|
||
(loop with headlines-to-expand = (if (parent-collapsed-p) node nil)
|
||
and index = (if (parent-collapsed-p) (1+ (current-index)) -1)
|
||
for n = (next-node) then (next-node)
|
||
until (or (null n) (<= (node-depth) depth))
|
||
when (and (parent-collapsed-p) (= index -1))
|
||
do (setf index (current-index))
|
||
when (eq n (current-headline))
|
||
do (progn
|
||
(loop while (<= (node-depth) (parent-depth))
|
||
do (pop depth/visibility))
|
||
(when (and (/= index -1) (not (parent-collapsed-p)))
|
||
(expand-those-headlines index count headlines-to-expand)
|
||
(setf index -1
|
||
count 0
|
||
headlines-to-expand nil)
|
||
(push-depth/visibility (node-depth) (property-of n :visibility))
|
||
(cond
|
||
((eq recurse t)
|
||
(push n headlines-to-expand))
|
||
((and (listp recurse) (eq n (first recurse)))
|
||
(pop recurse)
|
||
(push n headlines-to-expand)))))
|
||
count (/= index -1) into count
|
||
finally (when (/= index -1)
|
||
(expand-those-headlines index count headlines-to-expand)))))))))
|
||
|
||
(defun collapse-headline ()
|
||
(assert (eq (current-visual-node) (current-node)))
|
||
(let* ((node (current-visual-node))
|
||
(depth (node-depth)))
|
||
(assert (eq node (current-visual-headline)))
|
||
(save-excursion
|
||
(destructuring-bind (count . headlines)
|
||
(save-excursion
|
||
(loop for n = (next-visual-node) then (next-visual-node)
|
||
until (or (null n) (<= (visual-node-depth) depth))
|
||
count n into count
|
||
when (eq n (current-visual-headline))
|
||
collect n into headlines
|
||
finally (return (cons count headlines))))
|
||
(when (> count 0)
|
||
(hiding-rows ((1+ (current-visual-index)) count)
|
||
(loop for n in headlines
|
||
do (progn
|
||
(assert (subtypep (type-of n) 'org-headline))
|
||
(setf (property-of n :visibility) :collapsed)))
|
||
(setf (property-of node :visibility) :collapsed)))))))
|
||
|
||
|
||
|
||
(defun construct-org-model ()
|
||
(let ((model (qnew "QAbstractListModel")))
|
||
(qoverride model "rowCount(QModelIndex)"
|
||
(lambda (index)
|
||
(declare (ignore index))
|
||
*visual-nodes-count*))
|
||
(qoverride model "data(QModelIndex,int)"
|
||
(lambda (index role)
|
||
(let ((row (|row| index)))
|
||
(when (and (> row -1) (< row *visual-nodes-count*))
|
||
(let ((item (goto-visual-index row)))
|
||
(case role
|
||
(#.+nodetype-role+
|
||
(qvariant-from-value (string-downcase (symbol-name (type-of item)))
|
||
"QString"))
|
||
(#.+rawtext-role+
|
||
(qvariant-from-value (raw-text-of item) "QString"))
|
||
(#.+depth-role+
|
||
(qvariant-from-value (node-depth) "int"))
|
||
(#.+title-role+
|
||
(qvariant-from-value (title-of item) "QString"))
|
||
(#.+last-item-role+
|
||
(qvariant-from-value (= row (1- *visual-nodes-count*)) "bool"))))))))
|
||
(qoverride model "roleNames()"
|
||
(lambda ()
|
||
(list (cons +nodetype-role+ "nodeType")
|
||
(cons +rawtext-role+ "rawtext")
|
||
(cons +depth-role+ "depth")
|
||
(cons +title-role+ "title")
|
||
(cons +last-item-role+ "isLastItem"))))
|
||
(when *org-model*
|
||
(qdelete *org-model*))
|
||
(setf *org-model* model)
|
||
#+harbour-sextant
|
||
(|setContextProperty| (|rootContext| qml:*quick-view*) "orgModel" *org-model*)))
|
||
|
||
(defun make-org-model (pathname org-document &optional force)
|
||
(when (or (null *org-model*) force)
|
||
(construct-org-model))
|
||
(setf *current-pathname* pathname)
|
||
(|beginResetModel| *org-model*)
|
||
(init-cursor org-document)
|
||
(setf *visual-nodes-count* (save-excursion
|
||
(loop for node = (current-visual-node) then (next-visual-node)
|
||
while node count node)))
|
||
(|endResetModel| *org-model*))
|