path: root/lisp/+org.el

;;; +org.el -*- lexical-binding: t; -*-

;;; Code:

(require 'org)
(require 'org-element)
(require 'ox)

;;; org-return-dwim - https://github.com/alphapapa/unpackaged.el
;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/

(defun +org-element-descendant-of (type element)
  "Return non-nil if ELEMENT is a descendant of TYPE.
TYPE should be an element type, like `item' or `paragraph'.
ELEMENT should be a list like that returned by `org-element-context'."
  ;; MAYBE: Use `org-element-lineage'.
  (when-let* ((parent (org-element-property :parent element)))
    (or (eq type (car parent))
        (+org-element-descendant-of type parent))))

(defun +org-return-dwim (&optional prefix)
  "A helpful replacement for `org-return'.  With PREFIX, call `org-return'.

On headings, move point to position after entry content.  In
lists, insert a new item or end the list, with checkbox if
appropriate.  In tables, insert a new row or end the table."
  (interactive "P")
  ;; Auto-fill if enabled
  (when auto-fill-function
    (if (listp auto-fill-function)
        (dolist (func auto-fill-function)
          (funcall func))
      (funcall auto-fill-function)))
  (if prefix
      ;; Handle prefix args
      (pcase prefix
        ('(4) (newline))
        ('(16) (newline 2))
        ;; this is ... not ideal. but whatever.
        (_ (newline prefix)))
    (cond
     ;; Act depending on context around point.
     ((and org-return-follows-link
           (eq 'link (car (org-element-context))))
      ;; Link: Open it.
      (org-open-at-point-global))

     ((org-at-heading-p)
      ;; Heading: Move to position after entry content.
      ;; NOTE: This is probably the most interesting feature of this function.
      (let ((heading-start (org-entry-beginning-position)))
        (goto-char (org-entry-end-position))
        (cond ((and (org-at-heading-p)
                    (= heading-start (org-entry-beginning-position)))
               ;; Entry ends on its heading; add newline after
               (end-of-line)
               (insert "\n\n"))
              (t
               ;; Entry ends after its heading; back up
               (forward-line -1)
               (end-of-line)
               (when (org-at-heading-p)
                 ;; At the same heading
                 (forward-line)
                 (insert "\n")
                 (forward-line -1))
               (while (not
                       (looking-back
                        (rx (repeat 3 (seq (optional blank) "\n")))
                        nil))
                 (insert "\n"))
               (forward-line -1)))))

     ((org-at-item-checkbox-p)
      ;; Checkbox: Insert new item with checkbox.
      (org-insert-todo-heading nil))

     ((org-in-item-p)
      ;; Plain list
      (let* ((context (org-element-context))
             (first-item-p (eq 'plain-list (car context)))
             (itemp (eq 'item (car context)))
             (emptyp (eq (org-element-property :contents-begin context)
                         (org-element-property :contents-end context)))
             (item-child-p
              (+org-element-descendant-of 'item context)))
        ;; The original function from unpackaged just tested the (or ...) test
        ;; in this cond, in an if.  However, that doesn't auto-end nested
        ;; lists.  So I made this form a cond and added the (and...) test in
        ;; the first position, which is clunky (the delete-region... stuff
        ;; comes twice) and might not be needed.  More testing, obviously, but
        ;; for now, it works well enough.
        (cond ((and itemp emptyp)
               (delete-region (line-beginning-position) (line-end-position))
               (insert "\n\n"))
              ((or first-item-p
                   (and itemp (not emptyp))
                   item-child-p)
               (org-insert-item))
              (t (delete-region (line-beginning-position) (line-end-position))
                 (insert "\n")))))

     ((when (fboundp 'org-inlinetask-in-task-p)
        (org-inlinetask-in-task-p))
      ;; Inline task: Don't insert a new heading.
      (org-return))

     ((org-at-table-p)
      (cond ((save-excursion
               (beginning-of-line)
               ;; See `org-table-next-field'.
               (cl-loop with end = (line-end-position)
                        for cell = (org-element-table-cell-parser)
                        always (equal (org-element-property :contents-begin cell)
                                      (org-element-property :contents-end cell))
                        while (re-search-forward "|" end t)))
             ;; Empty row: end the table.
             (delete-region (line-beginning-position) (line-end-position))
             (org-return))
            (t
             ;; Non-empty row: call `org-return'.
             (org-return))))
     (t
      ;; All other cases: call `org-return'.
      (org-return)))))

(defun +org-table-copy-down (n)
  "Call `org-table-copy-down', or `org-return' outside of a table.
N is passed to the functions."
  (interactive "p")
  (if (org-table-check-inside-data-field 'noerror)
      (org-table-copy-down n)
    (+org-return-dwim n)))

;;; org-fix-blank-lines - unpackaged.el

(defun +org-fix-blank-lines (&optional prefix)
  "Ensure blank lines around headings.
Optional PREFIX argument operates on the entire buffer.
Drawers are included with their headings."
  (interactive "P")
  (org-map-entries (lambda ()
                     (org-with-wide-buffer
                      ;; `org-map-entries' narrows the buffer, which
                      ;; prevents us from seeing newlines before the
                      ;; current heading, so we do this part widened.
                      (while (not (looking-back "\n\n" nil))
                        ;; Insert blank lines before heading.
                        (insert "\n")))
                     (let ((end (org-entry-end-position)))
                       ;; Insert blank lines before entry content
                       (forward-line)
                       (while (and (org-at-planning-p)
                                   (< (point) (point-max)))
                         ;; Skip planning lines
                         (forward-line))
                       (while (re-search-forward
                               org-drawer-regexp end t)
                         ;; Skip drawers. You might think that
                         ;; `org-at-drawer-p' would suffice, but for
                         ;; some reason it doesn't work correctly when
                         ;; operating on hidden text.  This works, taken
                         ;; from `org-agenda-get-some-entry-text'.
                         (re-search-forward "^[ \t]*:END:.*\n?" end t)
                         (goto-char (match-end 0)))
                       (unless (or (= (point) (point-max))
                                   (org-at-heading-p)
                                   (looking-at-p "\n"))
                         (insert "\n"))))
                   t
                   (if prefix
                       nil
                     'tree)))

;;; org-count-words

(defun +org-count-words-stupidly (start end &optional limit)
  "Count words between START and END, ignoring a lot.

Since this function is, for some reason, pricy, the optional
parameter LIMIT sets a word limit at which to stop counting.
Once the function hits that number, it'll return -LIMIT
instead of the true count."
  (interactive (list nil nil))
  (cond ((not (called-interactively-p 'any))
         (let ((words 0)
               (continue t))
           (save-excursion
             (save-restriction
               (narrow-to-region start end)
               (goto-char (point-min))
               (while (and continue
                           (< (point) (point-max)))
                 (cond
                  ;; Ignore comments
                  ((or (org-at-comment-p)
                       (org-in-commented-heading-p))
                   (forward-line))
                  ;; Ignore headings
                  ((or (org-at-heading-p))
                   (forward-line))
                  ;; Ignore property and log drawers
                  ((or (looking-at org-drawer-regexp)
                       (looking-at org-clock-drawer-re))
                   (search-forward ":END:" nil :noerror)
                   (forward-line))
                  ;; Ignore DEADLINE and SCHEDULED keywords
                  ((or (looking-at org-deadline-regexp)
                       (looking-at org-scheduled-regexp)
                       (looking-at org-closed-time-regexp))
                   (forward-line))
                  ;; Ignore tables
                  ((org-at-table-p) (forward-line))
                  ;; Ignore hyperlinks, but count the descriptions
                  ((looking-at org-link-bracket-re)
                   (when-let ((desc (match-string-no-properties 5)))
                     (save-match-data
                       (setq words (+ words
                                      (length (remove ""
                                                      (org-split-string
                                                       desc "\\W")))))))
                   (goto-char (match-end 0)))
                  ;; Ignore source blocks
                  ((org-in-src-block-p) (forward-line))
                  ;; Ignore blank lines
                  ((looking-at "^$")
                   (forward-line))
                  ;; Count everything else
                  (t
                   ;; ... unless it's in a few weird contexts
                   (let ((contexts (org-context)))
                     (cond ((or (assoc :todo-keyword contexts)
                                (assoc :priority contexts)
                                (assoc :keyword contexts)
                                (assoc :checkbox contexts))
                            (forward-word-strictly))

                           (t (setq words (1+ words))
                              (if (and limit
                                       (> words limit))
                                  (setq words (- limit)
                                        continue nil))
                              (forward-word-strictly)))))))))
           words))
        ((use-region-p)
         (message "%d words in region"
                  (+org-count-words-stupidly (region-beginning)
                                                 (region-end))))
        (t
         (message "%d words in buffer"
                  (+org-count-words-stupidly (point-min)
                                                 (point-max))))))

;;; org-insert-link-dwim - https://xenodium.com/emacs-dwim-do-what-i-mean/

(defun +org-insert-link-dwim ()
  "Like `org-insert-link' but with personal dwim preferences."
  (interactive)
  (let* ((point-in-link (org-in-regexp org-link-any-re 1))
         (clipboard-url (when (string-match-p
                               (rx (sequence bos
                                             (or "http"
                                                 "gemini"
                                                 "gopher")))
                               (current-kill 0))
                          (current-kill 0)))
         (region-content (when (region-active-p)
                           (buffer-substring-no-properties (region-beginning)
                                                           (region-end)))))
    (cond ((and region-content clipboard-url (not point-in-link))
           (delete-region (region-beginning) (region-end))
           (insert (org-link-make-string clipboard-url region-content)))
          ((and clipboard-url (not point-in-link))
           (insert (org-link-make-string
                    clipboard-url
                    (read-string  "title: "
                                  (with-current-buffer
                                      (url-retrieve-synchronously
                                       clipboard-url)
                                    (dom-text
                                     (car
                                      (dom-by-tag (libxml-parse-html-region
                                                   (point-min)
                                                   (point-max))
                                                  'title))))))))
          (t
           (call-interactively 'org-insert-link)))))

;;; Navigate headings with widening

(defun +org-next-heading-widen (arg)
  "Find the ARGth next org heading, widening if necessary."
  (interactive "p")
  (let ((current-point (point))
        (point-target (if (> arg 0) (point-max) (point-min))))
    (org-next-visible-heading arg)
    (when (and (buffer-narrowed-p)
               (= (point) point-target)
               (or (and (> arg 0))
                   (and (< arg 0)
                        (= (point) current-point))))
      (widen)
      (org-next-visible-heading arg))))

(defun +org-previous-heading-widen (arg)
  "Find the ARGth previous org heading, widening if necessary."
  (interactive "p")
  (+org-next-heading-widen (- arg)))

;;; Hooks & Advice

(defun +org-before-save@prettify-buffer ()
  (save-mark-and-excursion
    (mark-whole-buffer)
    ;;(org-fill-paragraph nil t)
    (+org-fix-blank-lines t)
    (org-align-tags t)))

(defun +org-delete-backward-char (N)
  "Keep tables aligned while deleting N characters backward.
When deleting backwards, in tables this function will insert
whitespace in front of the next \"|\" separator, to keep the
table aligned.  The table will still be marked for re-alignment
if the field did fill the entire column, because, in this case
the deletion might narrow the column."
  (interactive "p")
  (save-match-data
    (org-check-before-invisible-edit 'delete-backward)
    (if (and (= N 1)
             (not overwrite-mode)
             (not (org-region-active-p))
             (not (eq (char-before) ?|))
             (save-excursion (skip-chars-backward " \t") (not (bolp)))
             (looking-at-p ".*?|")
             (org-at-table-p))
        (progn (forward-char -1) (org-delete-char 1))
      (backward-delete-char-untabify N)
      (org-fix-tags-on-the-fly))))

;;; Smarter {super,sub}scripts
;; https://old.reddit.com/r/emacs/comments/qzlzm0/what_are_your_top_key_bindings_rebindings_minor/hmwyhm3/
;; I don't use this currently because I found out about
;; `org-pretty-entities-include-sub-superscripts', which really does exactly
;; what I wanted.

(defface +org-script-markers '((t :inherit shadow))
  "Face to be used for sub/superscripts markers i.e., ^, _, {, }.")

;; Hiding the super and subscript markers is extremely annoying
;; since any remotely complex equation becomes a chore.  And leaving
;; it not raised is jarring to the eye.  So this fontifies the
;; buffer just like how auctex does -- use a muted colour to
;; highlight the markup and raise the script.
(defun +org-raise-scripts (limit)
  "Differences from `org-raise-scripts' are:

- It doesn't actually hide the markup used for super and subscript.
- It uses a custom face to highlight the markup: +org-script-markers.
- It doesn't require `org-pretty-entities' to be t."
  (when (and org-pretty-entities-include-sub-superscripts
             (re-search-forward
              (if (eq org-use-sub-superscripts t)
                  org-match-substring-regexp
                org-match-substring-with-braces-regexp)
              limit t))
    (let* ((pos (point)) table-p comment-p
           (mpos (match-beginning 3))
           (emph-p (get-text-property mpos 'org-emphasis))
           (link-p (get-text-property mpos 'mouse-face))
           (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face))))
      (goto-char (point-at-bol))
      (setq table-p (looking-at-p org-table-dataline-regexp)
            comment-p (looking-at-p "^[ \t]*#[ +]"))
      (goto-char pos)
      ;; Handle a_b^c
      (when (member (char-after) '(?_ ?^)) (goto-char (1- pos)))
      (unless (or comment-p emph-p link-p keyw-p)
        (put-text-property (match-beginning 3) (match-end 0)
                           'display
                           (if (equal (char-after (match-beginning 2)) ?^)
                               ;; (nth (if table-p 3 1) org-script-display)
                               (nth 3 org-script-display)
                             ;; (nth (if table-p 2 0) org-script-display)
                             (nth 2 org-script-display)))
        (put-text-property (match-beginning 2) (match-end 2)
                           'face 'vz/org-script-markers)
        (when (and (eq (char-after (match-beginning 3)) ?{)
                   (eq (char-before (match-end 3)) ?}))
          (put-text-property (match-beginning 3) (1+ (match-beginning 3))
                             'face '+org-script-markers)
          (put-text-property (1- (match-end 3)) (match-end 3)
                             'face '+org-script-markers)))
      t)))

;; Extra link types

(defun +org-tel-open (number _)
  "Notify the user of what phone NUMBER to call."
  (message "Call: %s" number))

(provide '+org)
;;; +org.el ends here