path: root/lisp/acdw-org.el

;;; acdw-org.el --- My org customizations  -*- lexical-binding: t; -*-

;;; Code:

(require 'cl-lib)

;;; Variables

(defcustom org-agenda-skip-file-regexp nil
  "Files matching this regexp are removed from `org-agenda-files'."
  :group 'org-agenda
  :type 'regexp)

;;; Functions


;;; DWIM

;; https://github.com/alphapapa/unpackaged.el,
;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
(defun +org-return-dwim (&optional arg)
  "A helpful replacement for `org-return'.
When called interactively with \\[universal-argument], call `org-return'
itself.  Other values of ARG will call `newline' with that ARG."
  (interactive "P")
  ;; Auto-fill if enabled
  (when auto-fill-function
    (dolist (func (ensure-list auto-fill-function))
      (funcall func)))
  (cl-letf* ((el (org-element-at-point))
             ((symbol-function 'el-child-of)
              (lambda (&rest types)
                (org-element-lineage el types t))))
    (cond                                ; Figure out what we're going to do
     (arg                                ; Handle prefix ARG
      (pcase arg
        ('(4) (org-return t nil t))
        (_ (newline arg t))))
     ((and org-return-follows-link      ; Open a link
           (el-child-of 'link))
      (org-open-at-point-global))
     ((org-at-heading-p)                ; Open a paragraph after a heading
      (let ((heading-start (org-entry-beginning-position)))
        (goto-char (org-entry-end-position))
        (cond ((and (org-at-heading-p)      ; Entry is only a heading
                    (= heading-start (org-entry-beginning-position)))
               (end-of-line)
               (newline 2))
              (:else                    ; Entry is more than a heading
               (forward-line -1)
               (end-of-line)
               (when (org-at-heading-p)
                 ;; Open a paragraph
                 (forward-line)
                 (newline)
                 (forward-line -1))
               (while (not (looking-back "\\(?:[[:blank:]]?\n\\)\\{3\\}" 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 el))
             (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 (el-child-of 'item)))
        (cond ((and itemp emptyp)
               ;; This test has to be here even though it's the same as the
               ;; :else clause, because an item that's empty will also satisfy
               ;; the next clause.
               (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))
              (:else
               (delete-region (line-beginning-position) (line-end-position))
               (newline)))))
     ((and (fboundp 'org-inlinetask-in-task-p) ; Just return for inline tasks
           (org-inlinetask-in-task-p))
      (org-return))
     ((org-at-table-p)                  ; Insert a new table row
      (cond ((save-excursion            ; Empty row: end the table
               (beginning-of-line)
               (cl-loop with end = (line-end-position)
                        for cell = (org-element-table-cell-parser)
                        always (eq (org-element-property :contents-begin cell)
                                   (org-element-property :contents-end cell))
                        while (re-search-forward "|" end t)))
             (delete-region (line-beginning-position) (line-end-position))
             (org-return))
            (:else                      ; Non-empty row
             (org-return))))
     (:else                             ; Something else
      (org-return)))))

(defun +org-table-copy-down|+org-return-dwim (&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)))


;;; Buffer view cleanup

(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))))))))


;;; Copy rich text to the keyboard

;; Thanks to Oleh Krehel:
;; https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard
;; So.  Emacs can't do this itself because it doesn't support sending clipboard
;; or selection contents as text/html.  We have to use xclip instead.
;; (defun org-to-html-to-clipboard (&rest org-export-args)
;;   "Export current org buffer to HTML, then copy it to the clipboard.
;; ORG-EXPORT-ARGS are passed to `org-export-to-file'."
;;   (let ((f (make-temp-file "org-html-export")))
;;     (apply #'org-export-to-file 'html f org-export-args)
;;     (start-process "xclip" " *xclip*"
;;                    "xclip" "-verbose" "-i" f
;;                    "-t" "text/html" "-selection" "clipboard")
;;     (message "HTML pasted to clipboard.")))

;; Wayland version.. TODO: make it work for both
(defun org-to-html-to-clipboard (&rest org-export-args)
  "Export current org buffer to HTML, then copy it to the clipboard.
ORG-EXPORT-ARGS are passed to `org-export-to-file'."
  (let ((buf (generate-new-buffer "*org-html-clipboard*" t)))
    (apply #'org-export-to-buffer 'html buf org-export-args)
    (with-current-buffer buf
      (call-process-region (point-min) (point-max)
                           "wl-copy" nil nil nil
                           "-t" "text/html")
      (kill-buffer-and-window))
    (message "HTML copied to clipboard.")))

(defun org-subtree-to-html-to-clipboard ()
  "Export current subtree to HTML."
  (interactive)
  (org-to-html-to-clipboard nil :subtree))


;;; Prompting

(defun +org-prompt-for-property (property &optional clipboardp insert list)
  "Prompt for PROPERTY and return a properly-formatted string.
Pre-fill the input with clipboard contents if they match CLIPBOARDP.  If
CLIPBOARDP is nil or missing, don't pre-fill.

If INSERT is non-nil, insert the property into the property
drawer of the current org tree.

If LIST is non-nil, return the result as a list instead of a string."
  (let* ((kill (current-kill 0))
         (value (read-string (concat property ": ")
                             (when (and clipboardp
                                        (or (eq clipboardp t)
                                            (funcall clipboardp kill)))
                               kill))))
    (when insert
      (org-set-property property value))
    (if list
        (list property value)
      (format ":%s: %s" property value))))

(defun +org-prompt-tags (&optional prompt global)
  (let* ((buffer (org-capture-get :buffer))
         (file (buffer-file-name (or (buffer-base-buffer buffer) buffer)))
         (org-last-tags-completion-table
          (org-global-tags-completion-table
           (if global (org-agenda-files) (list file))))
         (org-add-colon-after-tag-completion t)
         (ins (mapconcat
               #'identity
               (let ((crm-separator "[ \t]*:[ \t]*"))
                 (completing-read-multiple
                  (or prompt "Tags: ")
                  org-last-tags-completion-table nil nil nil
                  'org-tags-history))
               ":")))
    (when (org-string-nw-p ins)
      (prog1 (concat
              (unless (eq (char-before) ?:) ":")
              ins
              (unless (eq (char-after) ?:) ":"))
        (when (org-at-heading-p) (org-align-tags))))))


;;; Navigating headings

(defun org-next-visible-heading-unfolding (arg)
  (interactive "p")
  (when (let ((pt (org-next-visible-heading arg)))
          (and (buffer-narrowed-p)
               (or (= (point) (point-min))
                   (and pt
                        (= pt (point-max))))))
    (widen)
    (org-next-visible-heading arg)
    (org-narrow-to-subtree)))

(defun org-previous-visible-heading-unfolding (arg)
  (interactive "p")
  (org-next-visible-heading-unfolding (- arg)))

(defun org-up-heading-unfolding (arg)
  (interactive "p")
  (when (let ((pt (outline-up-heading arg)))
          (and (buffer-narrowed-p)
               (= (point) (point-min))))
    (widen)
    (org-up-heading-unfolding arg)
    (org-narrow-to-subtree)))


;;; Misc.

(defun org-clock-in-or-out (prefix)
  "If clocked in, clock out.  Otherwise, clock in."
  (interactive "P")
  (if (org-clocking-p)
      (org-clock-out prefix)
    (org-clock-in prefix)))


;;; Faces

(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.")


;;; Packages

(use-package org
  :defer t
  :custom-face
  (org-level-1 ((t :inherit fixed-pitch
                   :weight bold
                   :slant italic
                   :height 1.0)))
  (org-level-2 ((t :inherit fixed-pitch
                   :weight bold
                   :slant italic
                   :height 1.0)))
  (org-level-3 ((t :inherit fixed-pitch
                   :weight bold
                   :height 1.0)))
  (org-level-4 ((t :inherit org-level-3)))
  (org-level-5 ((t :inherit org-level-4)))
  (org-level-6 ((t :inherit org-level-5)))
  (org-level-7 ((t :inherit org-level-6)))
  (org-level-8 ((t :inherit org-level-7)))
  (org-drawer ((t :inherit fixed-pitch)))
  (org-property-value ((t :inherit fixed-pitch)))
  (org-special-keyword ((t :inherit fixed-pitch)))
  (org-indent ((t :inherit fixed-pitch)))
  (org-table ((t :inherit fixed-pitch)))
  :config
  ;; Options
  (setopt org-adapt-indentation nil
          org-auto-align-tags t
          org-archive-mark-done t
          org-fold-catch-invisible-edits 'show-and-error
          org-clock-clocked-in-display 'mode-line
          org-clock-string-limit 0
          org-clock-persist nil
          org-confirm-babel-evaluate nil
          org-cycle-separator-lines 0
          org-deadline-warning-days 0
          org-directory (sync/ "org/" t)
          org-ellipsis (or (bound-and-true-p truncate-string-ellipsis) "…")
          org-emphasis-alist
          '(("*" org-bold)
            ("/" org-italic)
            ("_" org-underline)
            ("=" org-verbatim)
            ("~" org-code)
            ("+" org-strikethrough))
          org-fontify-done-headline t
          org-fontify-quote-and-verse-blocks t
          org-fontify-whole-heading-line t
          org-hide-emphasis-markers t
          org-html-coding-system 'utf-8-unix
          org-image-actual-width (list (* (window-font-width)
                                          (- fill-column 8)))
          org-imenu-depth 3
          org-indent-indentation-per-level 0
          org-indent-mode-turns-on-hiding-stars nil
          org-insert-heading-respect-content t
          org-list-demote-modify-bullet '(("-" . "+")
                                          ("+" . "-"))
          org-log-done 'time
          org-log-into-drawer t
          org-num-skip-commented t
          org-num-skip-unnumbered t
          org-num-skip-footnotes t
          org-outline-path-complete-in-steps nil
          org-pretty-entities t
          org-pretty-entities-include-sub-superscripts nil
          org-refile-targets '((nil . (:maxlevel . 2))
                               (org-agenda-files . (:maxlevel . 1)))
          org-refile-use-outline-path 'file
          org-special-ctrl-a/e t
          org-special-ctrl-k t
          org-src-fontify-natively t
          org-src-tab-acts-natively t
          org-src-window-setup 'current-window
          org-startup-truncated nil
          org-startup-with-inline-images t
          org-tags-column 0 ;(- 0 fill-column -3)
          org-todo-keywords '((sequence "TODO(t)" "WAIT(w@/!)" "ONGOING(o@)"
                                        "|" "DONE(d!)" "ASSIGNED(a@/!)")
                              (sequence "|" "CANCELED(k@)")
                              (sequence "MEETING(m)"))
          org-use-fast-todo-selection 'auto
          org-use-speed-commands t
          org-element-use-cache nil)
  ;; Keys
  (keymap-set org-mode-map "C-M-k" #'kill-paragraph)
  (keymap-set org-mode-map "C-M-t" #'transpose-paragraphs)
  (keymap-set org-mode-map "RET" #'+org-return-dwim)
  (keymap-set org-mode-map "S-<return>" #'+org-table-copy-down|+org-return-dwim)
  (keymap-unset org-mode-map "C-'" t)
  (keymap-unset org-mode-map "C-," t)
  (keymap-set org-mode-map "C-c C-n" #'org-next-visible-heading-unfolding)
  (keymap-set org-mode-map "C-c C-p" #'org-previous-visible-heading-unfolding)
  (keymap-set org-mode-map "C-c C-u" #'org-up-heading-unfolding)
  ;; Hooks
  (add-hook 'org-mode-hook
            (defun org-mode@setup ()
              (when (require 'visual-fill-column nil t)
                (setq-local visual-fill-column-extra-text-width '(2 . 2))
                (visual-fill-column-mode))
              (variable-pitch-mode)
              (turn-off-auto-fill)
              (org-indent-mode)
              (abbrev-mode)
              (add-hook 'before-save-hook
                        (defun before-save@org-mode@before-save ()
                          (org-align-tags 'all)
                          (+org-hide-drawers-except-point)
                          )
                        nil :local)))
  ;; Extra font-lock keywords
  (font-lock-add-keywords
   'org-mode
   `(;; List markers => org-indent
     (,(concat
        "^[     ]*\\(\\(?:[-+]\\|\\(?:[0-9]+\\|[A-Za-z]\\)[.)]\\)"
        "\\(?:[         ]+\\|$\\)\\)"
        "\\(?:\\[@\\(?:start:\\)?\\([0-9]+\\|[A-Za-z]\\)\\]"
        "[      ]*\\)?"
        "\\(?:\\(\\[[ X-]\\]\\)"
        "\\(?:[         ]+\\|$\\)\\)?")
      0 'org-indent))))

(use-package org-clock
  :bind (:map org-mode-map
              ("<f8>" . org-clock-in-or-out))
  :config
  (setopt org-clock-clocked-in-display 'mode-line
          ;; global-mode-string
          ;; '((t jabber-activity-mode-string)
          ;;   (:eval (when (org-clocking-p) org-mode-line-string))
          ;;   (display-time-mode display-time-string))
          )
  ;; (add-hook 'org-clock-in-hook (defun org-clock@remove-from-global-mode-string ()
  ;;                                (setq global-mode-string
  ;;                                      (delq 'org-mode-line-string global-mode-string))))
  )

(use-package org-agenda
  :bind (("C-c a" . org-agenda))
  :config
  (setopt org-agenda-skip-deadline-if-done t
          org-agenda-skip-scheduled-if-done t
          org-agenda-span 10
          org-agenda-block-separator ?─
          org-agenda-time-grid '((daily today require-timed)
                                 (800 1000 1200 1400 1600 1800 2000)
                                 " ┄┄┄┄┄ " "┄┄┄┄┄┄┄┄┄┄┄┄┄┄┄")
          org-agenda-current-time-string "← now ───────────────"
          org-agenda-include-diary nil ; I use the org-diary features
          org-agenda-todo-ignore-deadlines 'near
          org-agenda-todo-ignore-scheduled 'future
          org-agenda-include-deadlines t
          org-deadline-warning-days 0
          org-agenda-show-future-repeats 'next
          org-agenda-window-setup 'current-window
          org-agenda-skip-file-regexp "sync-conflict"
          org-agenda-inhibit-startup t
          org-agenda-sticky t
          org-agenda-follow-indirect t
          org-stuck-projects '("TODO=\"WAIT\""
                               ("TODO" "NEXT")
                               nil
                               "")
          org-agenda-custom-commands
          `(("c" "Click Here Digital To-do"
             ((agenda "" ((org-agenda-overriding-header "Tasks")
                          (org-agenda-span 'fortnight)
                          (org-agenda-start-day "+0")
                          (org-agenda-skip-function
                           '(org-agenda-skip-subtree-if 'todo
                                                        '("WAIT" "MCKENZIE" "RACHEL")))))
              (stuck "" ((org-agenda-overriding-header "Waiting"))))
             ((org-agenda-files ',(list (progn (require 'chd)
                                               (chd/ "inbox-chd.org"))
                                        (sync/ "org/diary.org")))))))
  ;; Speedup agenda generation
  ;; https://orgmode.org/manual/Speeding-Up-Your-Agendas.html
  ;; https://orgmode.org/worg/agenda-optimization.html
  (setopt org-agenda-dim-blocked-tasks nil
          org-agenda-inhibit-startup t
          org-agenda-use-tag-inheritance nil
          org-agenda-ignore-properties '(effort appt stats category))
  ;; Hooks and advice
  (add-hook 'org-agenda-mode-hook #'truncate-lines-local-mode)
  (add-hook 'org-agenda-mode-hook #'hl-line-mode)
  (add-hook 'org-agenda-after-show-hook #'org-narrow-to-subtree)
  ;; (add-hook 'org-agenda-after-show-hook #'+org-hide-drawers-except-point)
  (define-advice org-agenda-files (:filter-return (files) skip-regexp)
    "Filter some files from `org-agenda'."
    (when org-agenda-skip-file-regexp
      (setq files
            (cl-remove-if (lambda (file)
                            (string-match-p org-agenda-skip-file-regexp
                                            file))
                          files)))
    files)
  (define-advice org-agenda (:around (orig &rest r) inhibit-hooks)
    (dlet ((org-mode-hook nil))
      (apply orig r)))
  (define-advice org-agenda-skip (:around (orig &rest r) fix-looking-at)
    (dlet ((comment-start-skip "^\\s-*#\\(?: \\|$\\)"))
      (apply orig r)))
  ;; (advice-remove 'org-agenda 'org-agenda@inhibit-hooks)
  (define-advice org-agenda-switch-to (:after (&rest _) do-hooks)
    (run-hooks 'org-mode-hook))
  (progress@around org-agenda-list "Building agenda")
  (with-eval-after-load 'org-agenda
    (add-to-list 'org-agenda-files (sync/ "org/diary.org"))))

(use-package org-capture
  :bind (("C-c c" . org-capture)))

(use-package ol                         ; org-link
  :after org
  :preface
  (defmacro +org-link-define-type (type args &rest body)
    "Define an org link TYPE.
A function named `+org-link-TYPE-open' will be created, with ARGS
as its arguments and BODY as its body.  BODY can be blank, in
which case the user will be messaged (This is a good do-nothing
effect for exporting link types)."
    (declare (indent 2)
             (doc-string 3)
             (debug (sexp sexp def-body)))
    (let ((fn (intern (format "+org-link-%s-open" type)))
          (body (or body `((message ,(format "%S: %%S" type)
                                    ,(car args)))))
          (type-string (format "%S" type)))
      `(prog1
           (defun ,fn ,args ,@body)
         (org-link-set-parameters ,type-string :follow #',fn))))
  :config
  (+org-link-define-type sms (number _))
  (+org-link-define-type tel (number _)))

(use-package ox                         ; org-export
  :after org
  :config
  (require 'ox-md)
  (setopt org-export-coding-system 'utf-8-unix
          org-export-headline-levels 8
          org-export-with-drawers nil
          org-export-with-section-numbers nil
          org-export-with-smart-quotes t
          org-export-with-sub-superscripts t
          org-export-with-toc nil))

(use-package org-word-count
  :load-path "~/src/org-word-count.el/"
  :hook org-mode-hook)

(use-package org-modern
  :ensure t
  :custom-face
  (org-modern-label ((t :inherit fixed-pitch
                        :height 1.0)))
  :hook (org-mode-hook)
  :config
  (setopt org-modern-star nil
          org-modern-list '((43 . "◦")
                            (45 . "•")
                            (42 . "‣"))
          org-hide-leading-stars nil
          org-modern-hide-stars nil
          org-tags-column 0
          org-modern-keyword nil
          org-modern-table nil))

(use-package org-taskwise
  :after org
  :load-path "~/src/org-taskwise.el/")

(provide 'acdw-org)
;;; acdw-org.el ends here