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

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


;;; 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
                   :height 1.2)))
  (org-level-2 ((t :inherit fixed-pitch
                   :weight bold
                   :height 1.1)))
  (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)))
  :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 7     ; just the clock bit
          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)
  ;; 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)
  ;; Hooks
  (add-hook 'org-mode-hook #'variable-pitch-mode)
  (autoload 'visual-fill-column-mode "visual-fill-column" nil t)
  (add-hook 'org-mode-hook #'visual-fill-column-mode)
  (add-hook 'org-mode-hook #'turn-off-auto-fill)
  (add-hook 'org-mode-hook #'org-indent-mode)
  (add-hook 'org-mode-hook #'abbrev-mode)
  (add-hook 'org-mode-hook
            (defun before-save@org-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-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)
  ;; 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)
  (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)
    (let ((org-mode-hook nil))
      (apply orig r)))
  (define-advice org-agenda-switch-to (:after (&rest _) do-hooks)
    (run-hooks 'org-mode-hook))
  (progress@around org-agenda-list "Building agenda"))

(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/emacs/org-word-count/"
  :hook org-mode-hook)

(use-package org-modern
  :ensure t
  :custom-face
  (org-modern-label ((t :inherit fixed-pitch
                        :height 1.0)))
  :config
  (setopt org-modern-star nil
          org-hide-leading-stars nil
          org-modern-hide-stars nil
          org-tags-column 0
          org-modern-keyword nil)
  (global-org-modern-mode))

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