path: root/lisp/ss-org.el

;;; ss-org.el --- Base Org configuration -*- lexical-binding: t; -*-

;;; Commentary:

;; Shared Org setup and note-opening helpers.

;;; Code:

(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)
    (define-key map (kbd "C-c C-k") #'ss-journal-session-dismiss)
    map)
  "Keymap for focused journal editing sessions.")

(defconst ss-journal-session-header-line
  "Journal session: C-c C-c save and dismiss, C-c C-k dismiss"
  "Header line shown during focused journal editing sessions.")

(define-minor-mode ss-journal-session-mode
  "Minor mode for focused journal editing sessions."
  :lighter " Journal-Session"
  :keymap ss-journal-session-mode-map
  (if ss-journal-session-mode
      (setq-local header-line-format ss-journal-session-header-line)
    (kill-local-variable 'header-line-format)))

(defun ss-journal-session-dismiss ()
  "End the focused journal session without saving automatically."
  (interactive)
  (widen)
  (ss-journal-session-mode -1)
  (quit-window nil (selected-window)))

(defun ss-journal-session-save-and-dismiss ()
  "Save the journal buffer, then end the focused journal session."
  (interactive)
  (save-buffer)
  (ss-journal-session-dismiss))

(defun ss-open-journal ()
  "Open today's journal entry in a focused session, creating it when needed."
  (interactive)
  (ss-open-journal-today-session))

(defun ss-open-journal-today-session ()
  "Open today's journal entry in a focused, dismissable session."
  (interactive)
  (find-file (ss-require-existing-file ss-journal-file))
  (widen)
  (unless (fboundp 'ss-journal-goto-date)
    (user-error "Journal date navigation is unavailable"))
  (ss-journal-goto-date nil 'create)
  (when (fboundp 'ss-journal-ensure-day-sections)
    (ss-journal-ensure-day-sections))
  (org-fold-show-entry)
  (org-fold-show-subtree)
  (org-narrow-to-subtree)
  (ss-journal-session-mode 1))

(defun ss-open-journal-full ()
  "Open `ss-journal-file' with the full buffer visible."
  (interactive)
  (find-file (ss-require-existing-file ss-journal-file))
  (widen))

(defun ss-open-moc ()
  "Open the central MOC note."
  (interactive)
  (find-file (ss-require-existing-file ss-moc-file)))

(defun ss-org-setup ()
  "Initialize base Org configuration."
  (use-package org
    :ensure nil
    :config
    (setq org-directory ss-org-directory
          org-hide-emphasis-markers t
          org-agenda-search-headline-for-time t
          org-agenda-custom-commands
          '(("c" "Clarify items" todo "CLARIFY"))
          org-todo-keywords
          '((sequence "TODO(t)" "CLARIFY(c)" "WAIT(w@/!)" "|"
                      "DONE(d)" "CANCELLED(x@)"))
          org-log-done 'note
          org-log-into-drawer t)
    (add-hook 'org-mode-hook
              (lambda ()
                (setq-local org-hide-emphasis-markers t)
                (when (fboundp 'olivetti-mode)
                  (olivetti-mode 1))
                (font-lock-flush)
                (font-lock-ensure))))

  (use-package git-auto-commit-mode
    :ensure t
    :pin melpa
    :commands (git-auto-commit-mode)
    :init
    (setq gac-shell-and
          (if (string-match-p "fish\\'" shell-file-name)
              " ; and "
            " && ")))

  (add-hook 'emacs-startup-hook
            (lambda ()
              (find-file (ss-require-existing-file ss-moc-file))))

  (ss-navigation-setup))

(provide 'ss-org)

;;; ss-org.el ends here