diff options
Diffstat (limited to 'lisp/ss-org.el')
| -rw-r--r-- | lisp/ss-org.el | 175 |
1 files changed, 174 insertions, 1 deletions
diff --git a/lisp/ss-org.el b/lisp/ss-org.el index 793ee1d..f1a2274 100644 --- a/lisp/ss-org.el +++ b/lisp/ss-org.el @@ -9,6 +9,177 @@ (require 'org) (require 'ss-core) +(defvar ss-navigation-back-stack nil + "Stack of older locations for `ss-jump-back'.") + +(defvar ss-navigation-forward-stack nil + "Stack of newer locations for `ss-jump-forward'.") + +(defvar ss-navigation--inhibit-recording nil + "When non-nil, suppress navigation history recording.") + +(defun ss-navigation--current-location () + "Return the current location as a marker-backed plist." + (unless (minibufferp (current-buffer)) + (list :marker (copy-marker (point-marker)) + :window-start + (when (window-live-p (selected-window)) + (copy-marker (window-start (selected-window))))))) + +(defun ss-navigation--location-valid-p (location) + "Return non-nil when LOCATION still points to a live buffer position." + (when-let ((marker (plist-get location :marker))) + (and (markerp marker) + (marker-buffer marker) + (marker-position marker)))) + +(defun ss-navigation--same-location-p (left right) + "Return non-nil when LEFT and RIGHT identify the same buffer position." + (and (ss-navigation--location-valid-p left) + (ss-navigation--location-valid-p right) + (eq (marker-buffer (plist-get left :marker)) + (marker-buffer (plist-get right :marker))) + (= (marker-position (plist-get left :marker)) + (marker-position (plist-get right :marker))))) + +(defun ss-navigation--prune-stack (stack) + "Return STACK with dead or duplicate locations removed." + (let (pruned previous) + (dolist (location stack (nreverse pruned)) + (when (and (ss-navigation--location-valid-p location) + (not (ss-navigation--same-location-p location previous))) + (push location pruned) + (setq previous location))))) + +(defun ss-navigation--push-location (stack-symbol location &optional clear-forward) + "Push LOCATION onto STACK-SYMBOL unless it duplicates the top entry. +When CLEAR-FORWARD is non-nil, reset `ss-navigation-forward-stack'." + (when (ss-navigation--location-valid-p location) + (set stack-symbol (ss-navigation--prune-stack (symbol-value stack-symbol))) + (unless (ss-navigation--same-location-p location (car (symbol-value stack-symbol))) + (set stack-symbol (cons location (symbol-value stack-symbol)))) + (when clear-forward + (setq ss-navigation-forward-stack nil)) + t)) + +(defun ss-navigation-push-current-location () + "Push the current location onto the back stack. +This is for significant navigation points only and clears forward history." + (interactive) + (ss-navigation--push-location + 'ss-navigation-back-stack + (ss-navigation--current-location) + 'clear-forward)) + +(defun ss-navigation--restore-location (location) + "Restore LOCATION, returning non-nil when successful." + (when (ss-navigation--location-valid-p location) + (let* ((marker (plist-get location :marker)) + (buffer (marker-buffer marker)) + (window-start (plist-get location :window-start))) + (switch-to-buffer buffer) + (goto-char marker) + (when (and (markerp window-start) + (eq (marker-buffer window-start) buffer) + (window-live-p (selected-window))) + (set-window-start (selected-window) + (marker-position window-start) + t)) + t))) + +(defun ss-navigation--jump-from-stack (stack-symbol target-symbol) + "Restore the next location from STACK-SYMBOL and push current onto TARGET-SYMBOL." + (set stack-symbol (ss-navigation--prune-stack (symbol-value stack-symbol))) + (when-let ((target (car (symbol-value stack-symbol)))) + (let ((current (ss-navigation--current-location))) + (set stack-symbol (cdr (symbol-value stack-symbol))) + (when (ss-navigation--location-valid-p current) + (ss-navigation--push-location target-symbol current)) + (let ((ss-navigation--inhibit-recording t)) + (ss-navigation--restore-location target))))) + +(defun ss-navigation--jump-via-command (command) + "Use COMMAND as a mark-ring fallback jump, recording forward history." + (when (fboundp command) + (let ((before (ss-navigation--current-location)) + after) + (let ((ss-navigation--inhibit-recording t)) + (condition-case nil + (call-interactively command) + (error nil))) + (setq after (ss-navigation--current-location)) + (when (and (ss-navigation--location-valid-p before) + (ss-navigation--location-valid-p after) + (not (ss-navigation--same-location-p before after))) + (ss-navigation--push-location 'ss-navigation-forward-stack before) + t)))) + +(defun ss-jump-back () + "Move backward through navigation history." + (interactive) + (or (ss-navigation--jump-from-stack + 'ss-navigation-back-stack + 'ss-navigation-forward-stack) + (ss-navigation--jump-via-command 'pop-global-mark) + (ss-navigation--jump-via-command 'pop-to-mark-command) + (progn + (message "No back location available") + nil))) + +(defun ss-jump-forward () + "Move forward through navigation history." + (interactive) + (or (ss-navigation--jump-from-stack + 'ss-navigation-forward-stack + 'ss-navigation-back-stack) + (progn + (message "No forward location available") + nil))) + +(defun ss-navigation--record-jump (original &rest args) + "Record the pre-jump location around ORIGINAL with ARGS." + (if ss-navigation--inhibit-recording + (apply original args) + (let ((before (ss-navigation--current-location)) + result) + (setq result (apply original args)) + (let ((after (ss-navigation--current-location))) + (when (and (ss-navigation--location-valid-p before) + (ss-navigation--location-valid-p after) + (not (ss-navigation--same-location-p before after))) + (ss-navigation--push-location + 'ss-navigation-back-stack + before + 'clear-forward))) + result))) + +(defun ss-navigation--advise-command (command) + "Wrap COMMAND so significant jumps record navigation history." + (unless (advice-member-p #'ss-navigation--record-jump command) + (advice-add command :around #'ss-navigation--record-jump))) + +(defun ss-navigation-setup () + "Install navigation history advice for note-related jump commands." + (dolist (command '(ss-open-journal + ss-open-journal-today-session + ss-open-journal-full + ss-open-moc)) + (ss-navigation--advise-command command)) + (with-eval-after-load 'org + (ss-navigation--advise-command 'org-open-at-point)) + (with-eval-after-load 'org-agenda + (dolist (command '(org-agenda-goto + org-agenda-switch-to + org-agenda-open-link)) + (ss-navigation--advise-command command))) + (with-eval-after-load 'denote + (ss-navigation--advise-command 'denote-open-or-create)) + (with-eval-after-load 'ss-crm + (dolist (command '(ss-crm-find + ss-crm-open + ss-crm-overview)) + (ss-navigation--advise-command command)))) + (defvar ss-journal-session-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'ss-journal-session-save-and-dismiss) @@ -105,7 +276,9 @@ (add-hook 'emacs-startup-hook (lambda () - (find-file (ss-require-existing-file ss-moc-file))))) + (find-file (ss-require-existing-file ss-moc-file)))) + + (ss-navigation-setup)) (provide 'ss-org) |