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

;;; Org Return DWIM
;; [[https://github.com/alphapapa/unpackaged.el][unpackaged]] and [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][kitchin]]

(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'."
  (interactive "P")
  ;; Auto-fill if enabled
  (when auto-fill-function
    (dolist (func (ensure-list auto-fill-function))
      (funcall func)))
  (cond
   (prefix                              ; Handle prefix
    (pcase prefix
      ('(4) (newline))
      ('(16) (newline 2))
      (_ (newline prefix))))
   ((and org-return-follows-link        ; Open link
         (eq 'link (car (org-element-context))))
    (org-open-at-point-global))
   ((org-at-heading-p)                  ; Open a line after a heading
    (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, so add 2 newlines
             (end-of-line)
             (newline 2))
            (t
             ;; Entry ends after its heading, so back up
             (forward-line -1)
             (end-of-line)
             (when (org-at-heading-p)
               (forward-line)
               (newline)
               (forward-line -1))
             (while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))
                                       nil))
               (newline))
             (forward-line -1)))))
   ((org-at-item-checkbox-p)            ; Insert a new checkbox item
    (end-of-line)
    (org-insert-todo-heading nil))
   ((org-in-item-p)                     ; Insert a new list item
    (let* ((context (org-element-context))
           (first-item-p (eq 'plain-list (car context)))
           (itemp (eq 'item (car context)))
           (emptyp (or
                    ;; This (regular) list item is empty
                    (eq (org-element-property :contents-begin context)
                        (org-element-property :contents-end context))
                    ;; This (definition) list item is empty
                    (looking-at " *::")))
           (item-child-p (+org-element-descendant-of 'item context)))
      (cond ((and itemp emptyp)
             (delete-region (line-beginning-position) (line-end-position))
             (newline))
            ((or first-item-p
                 (and itemp (not emptyp))
                 item-child-p)
             (org-end-of-item)
             (org-insert-item))
            (t
             (delete-region (line-beginning-position) (line-end-position))
             (newline)))))
   ((and (fboundp 'org-inlinetask-in-task-p) ; Don't insert a new heading with
         (org-inlinetask-in-task-p))         ; inline tasks
    (org-return))
   ((org-at-table-p)                    ; Insert a new org-table row
    (cond ((save-excursion
             (beginning-of-line)
             (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
           (org-return))))
   (t                                   ; Otherwise---just call `org-return'.
    (org-return))))

(defun +org-table-copy-down|+org-return (&optional n)
  "Call `org-table-copy-down' or `+org-return' depending on context."
  (interactive "P")
  (if (org-table-check-inside-data-field 'noerror)
      (org-table-copy-down (or n 1))
    (+org-return-dwim n)))

;;; Copy org trees as HTML

;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]].
(defun +org-export-clip-to-html
    (&optional async subtreep visible-only body-only ext-plist post-process)
  "Export region to HTML, and copy it to the clipboard.
Arguments ASYNC, SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST,
and POST-PROCESS are passed to `org-export-to-file'."
  (interactive) ; XXX: hould this be interactive?
  (message "Exporting Org to HTML...")
  (let ((org-tmp-file "/tmp/org.html"))
    (org-export-to-file 'html org-tmp-file
      async subtreep visible-only body-only ext-plist post-process)
    (start-process "xclip" "*xclip*"
                   "xclip" "-verbose"
                   "-i" org-tmp-file
                   "-t" "text/html"
                   "-selection" "clipboard"))
  (message "Exporting Org to HTML...done."))

;; Specialized functions
(defun +org-export-clip-subtree-to-html ()
  "Export current subtree to HTML."
  (interactive)
  (+org-export-clip-to-html nil :subtree))

;;; Unsmartify quotes and dashes and stuff.

(defun +org-unsmartify ()
  "Replace \"smart\" punctuation with their \"dumb\" counterparts."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "[“”‘’–—]" nil t)
      (let ((replace (pcase (match-string 0)
                       ((or "“" "”") "\"")
                       ((or "‘" "’") "'")
                       ("–" "--")
                       ("—" "---"))))
        (replace-match replace nil nil)))))

;;; A ... different ... `org-open-at-point-dwim'
;; I honestly don't remember what the difference is between this and the
;; O.G. one is.. hopefully this one fixes annoying stupid problems.

(defun +org-open-at-point-dwim (&optional arg)
  "Open thing at point, or if there isn't something, list things."
  (interactive "P")
  (save-excursion
    (let* ((this-char-type (org-element-type (org-element-context)))
           (prev-char-type (ignore-errors
                             (save-excursion
                               (backward-char)
                               (org-element-type (org-element-context)))))
           (types '(citation citation-reference clock comment comment-block
                             footnote-definition footnote-reference headline
                             inline-src-block inlinetask keyword link
                             node-property planning src-block timestamp))
           (type this-char-type))
      (when (and (memq this-char-type types) (memq prev-char-type types))
        (backward-char)
        (setq type prev-char-type))                  ; what the fuckckckckck
      ;; Okay, so this ^ is pretty janky and doesn't /really/ work that well,
      ;; especially on DEADLINE (and probably SCHEDULED) lines.  However, since
      ;; I really just want to open the list of URLs /most of the time/, I'm
      ;; fixing it like this instead.
      (unless (and (memq type types)
                   (ignore-errors (org-open-at-point arg)
                                  t))
        (while (not
                (progn
                  (org-back-to-heading)
                  (car (org-offer-links-in-entry (current-buffer) (point) 1))))
          (org-up-heading-all 1))
        (org-open-at-point arg)))))

;;; Skip invisible shit when moving around
(defun +org-ignore-invisible (fn &rest r)
  ":around ADVICE to ignore invisible text in `org-mode' buffers."
  ;; TODO: generalize to all modes
  (cond ((and (derived-mode-p #'org-mode)
              (org-invisible-p))
         (while (org-invisible-p)
           (forward-char))
         (apply fn r))
        (t (apply fn r))))

;;; Faces

;;; Better org faces
;; see `org-emphasis-alist'

(defface org-bold '((t (:weight bold)))
  "Bold face in `org-mode' documents.")

(defface org-italic '((t (:slant italic)))
  "Italic face in `org-mode' documents.")

(defface org-underline '((t (:underline t)))
  "Underline face in `org-mode' documents.")

(defface org-strikethrough '((t (:strike-through t)))
  "Strike-through face for `org-mode' documents.")

;; `org-verbatim' and `org-code' are apparently already things, so we skip them
;; here.

;;; Inhibit hooks on `org-agenda'
;; It's really annoying when I call `org-agenda' and five hundred Ispell
;; processes are created because I have `flyspell-mode' in the hook.  This mode
;; inhibits those hooks when entering the agenda, but runs them when opening the
;; actual buffer.

(defun +org-agenda-inhibit-hooks (fn &rest r)
  "Advice to inhibit hooks when entering `org-agenda'."
  (let ((org-mode-hook nil))
    (apply fn r)))

(defvar-local +org-hook-has-run-p nil
  "Whether `org-mode-hook' has run in the current buffer.")

(defun +org-agenda-switch-run-hooks (&rest _)
  "Advice to run `org-mode-hook' when entering org-mode.
This should only fire when switching to a buffer from `org-agenda'."
  (unless +org-hook-has-run-p
    (run-hooks 'org-mode-hook)
    (setq +org-hook-has-run-p t)))

(define-minor-mode +org-agenda-inhibit-hooks-mode
  "Inhibit `org-mode-hook' when opening `org-agenda'."
  :lighter " A/h"
  :global t
  (cond (+org-agenda-inhibit-hooks-mode
         (advice-add 'org-agenda :around #'+org-agenda-inhibit-hooks)
         (advice-add 'org-agenda-switch-to :after #'+org-agenda-switch-run-hooks))
        (:else
         (advice-remove 'org-agenda #'+org-agenda-inhibit-hooks)
         (advice-remove 'org-agenda-switch-to #'+org-agenda-switch-run-hooks))))

;;; Drawers
(defun +org-hide-drawers-except-point ()
    "Hide all drawers except for the one point is in."
    ;; Most of this bit is taken from `org-fold--hide-drawers'.
    (let ((pt (point))
          (begin (point-min))
          (end (point-max)))
      (save-excursion
        (goto-char begin)
        (while (and (< (point) end)
                    (re-search-forward org-drawer-regexp end t))
          (if (org-fold-folded-p nil 'drawer)
              (goto-char (org-fold-next-folding-state-change 'drawer nil end))
            (let* ((drawer (org-element-at-point))
                   (type (org-element-type drawer))
                   (el-begin (org-element-property :begin drawer))
                   (el-end (org-element-property :end drawer)))
              (when (memq type '(drawer property-drawer))
                (org-fold-hide-drawer-toggle
                 (if (< el-begin pt el-end) 'off 'on)
                 nil drawer)
                (goto-char el-end))))))))


(provide '+org)