;;; oni-org.el --- Org mode configuration            -*- lexical-binding: t; -*-

;; Copyright (C) 2019  Tom Willemse

;; Author: Tom Willemse <tom@ryuslash.org>
;; Keywords: local
;; Version: 2024.0701.144646
;; Package-Requires: (oni-yasnippet oni-hydra org org-edna diminish olivetti org-pretty-table)

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Configuration for `org-mode'. The icons used in
;; ‘org-agenda-category-icon-alist’ are from the following sites:

;; - bx*-*.svg: https://boxicons.com/ (bxs for Solid, and bx for not solid)
;; - mat-*.svg: https://fonts.google.com/icons?selected=Material+Icons
;; - bs-*.svg: https://icons.getbootstrap.com/

;; Add the following to your init file if you want to use this configuration:
;;
;;     (with-eval-after-load 'org (require 'oni-org))

;;; Code:

(require 'color)
(require 'diminish)
(require 'hydra)
(require 'ob)
(require 'org)
(require 'org-clock)
(require 'org-edna)
(require 'org-element)
(require 'org-faces)
(require 'org-habit)
(require 'org-protocol)
(require 'org-roam)
(require 'range)
(require 'subr-x)
(require 'yasnippet)

;;; Constants

(defconst oni-org-root
  (file-name-directory
   (or load-file-name
       (buffer-file-name)))
  "The directory where ‘oni-org’ was loaded from.")

(defconst oni-org-snippets-dir
  (expand-file-name "snippets" oni-org-root)
  "The directory where ‘oni-org’ stores its snippets.")

(defconst oni-org-icons-dir
  (expand-file-name "icons" oni-org-root)
  "The directory where ‘oni-org’ stores its icons.")

(defconst oni-org-todo-dir
  (expand-file-name "documents/exocortex-novus/tasks" (getenv "HOME"))
  "The directory where all the TODO notes are stored.")

(defconst oni-org-todo-inbox-file
  (expand-file-name "inbox.org" oni-org-todo-dir)
  "The inbox file for any notes.")

(defconst oni-org-todo-main-file
  (expand-file-name "todo.org" oni-org-todo-dir)
  "The main file for TODO notes.")

(defconst oni-org-todo-someday-file
  (expand-file-name "someday.org" oni-org-todo-dir)
  "The file for TODO notes I will want to do some day, but not today.")

(defconst oni-org-todo-tickler-file
  (expand-file-name "tickler.org" oni-org-todo-dir)
  "The tickler file for TODO notes of the future.")

;;; Functions

(defun oni-org-document-add-inline-images-startup ()
  "Add a line to the current org buffer that will make it load images inline."
  (interactive)
  (unless (derived-mode-p 'org-mode)
    (error "Not currently in an org-mode buffer"))
  (save-excursion
    (goto-char (point-min))
    (let ((header-end (or (search-forward "\n\n" nil t)
                          (point-max)))
          (case-fold-search t))
      (goto-char (point-min))
      (unless (search-forward "#+startup: inlineimages" header-end t)
        (goto-char (1- header-end))
        (insert "#+STARTUP: inlineimages\n")))))

(defun oni-org-document-remove-inline-images-startup ()
  "Remove a line to the current org buffer that will make it load images inline."
  (interactive)
  (unless (derived-mode-p 'org-mode)
    (error "Not currently in an org-mode buffer"))
  (save-excursion
    (goto-char (point-min))
    (let ((header-end (or (search-forward "\n\n" nil t)
                          (point-max)))
          (case-fold-search t))
      (goto-char (point-min))
      (when (search-forward "#+startup: inlineimages" header-end t)
        (kill-whole-line)))))

(defun oni-org-document-toggle-inline-images-startup ()
  "Add or remove a line to the current org buffer that will make it load images inline."
  (interactive)
  (unless (derived-mode-p 'org-mode)
    (error "Not currently in an org-mode buffer"))
  (save-excursion
    (goto-char (point-min))
    (let ((header-end (or (search-forward "\n\n" nil t)
                          (point-max)))
          (case-fold-search t))
      (goto-char (point-min))
      (if (search-forward "#+startup: inlineimages" header-end t)
          (kill-whole-line)
        (goto-char (1- header-end))
        (insert "#+STARTUP: inlineimages\n")))))

(defun oni-org-expand-to-home (file-name)
  "Expand FILE-NAME to the base directory for that system.
The base for all org files on Windows is u:/, but on my linux
installs it will always be ~."
  (let ((base-dir "~"))
    (expand-file-name file-name base-dir)))

(defun oni-org-set-yasnippet-condition ()
  "Change the ‘yas-buffer-local-condition’ variable to work for org.
This condition requires that the key used for the snippet is
located at the start of the line."
  (setq-local yas-buffer-local-condition
              '(looking-back (rx line-start (one-or-more (not space))))))

(defun oni-org-snippets-initialize ()
  "Initialize the snippets for ‘oni-org’."
  (when (boundp 'yas-snippet-dirs)
    (add-to-list 'yas-snippet-dirs oni-org-snippets-dir t))
  (yas-load-directory oni-org-snippets-dir))

(defun oni-org-maybe-change-todo-state (current-state)
  "Change the state of the current task to in-progress CURRENT-STATE is todo."
  (if (and (not org-capture-mode)
           (member current-state org-todo-heads))
      (cadr (member current-state org-todo-keywords-1))
    current-state))

;;;###autoload
(defun oni-org-open-index ()
  "Open the index of my org-based personal wiki."
  (interactive)
  (find-file (oni-org-expand-to-home "documents/exocortex-novus/index.org")))

(defun oni-org-color-for (object)
  "Generate a color for OBJECT by using its hash as a parameter for an LCh color."
  (apply #'color-rgb-to-hex
         (apply #'color-lab-to-srgb
                (color-lch-to-lab 65 30 (mod (sxhash-equal object) 360)))))

(defun oni-org-generate-todo-keyword-faces ()
  "Create faces for all todo keywords in the current buffer."
  (if-let ((keywords (cl-remove-if (lambda (tag) (assoc tag org-todo-keyword-faces))
                                   org-todo-keywords-1)))
      (append org-todo-keyword-faces
              (mapcar (lambda (keyword) (cons keyword (oni-org-color-for keyword)))
                      keywords))
    org-todo-keyword-faces))

(defun oni-org-generate-tag-faces ()
  "Create faces for all the tags in the current buffer."
  (if-let ((tags (cl-remove-if (lambda (tag) (assoc (car tag) org-tag-faces))
                               (org-get-buffer-tags))))
      (append org-tag-faces
              (mapcar (lambda (tag)
                        (let ((tag (car tag)))
                          (cons tag (oni-org-color-for tag))))
                      tags))
    org-tag-faces))

(defun oni-org-generate-priority-faces ()
  "Create faces for all the priorities in the current buffer."
  (let (new-faces)
    (range-map
     (lambda (x) (push (cons x (oni-org-color-for x)) new-faces))
     (cons (min org-priority-highest
                org-priority-lowest)
           (max org-priority-lowest
                org-priority-highest)))
    new-faces))

(defun oni-org-set-todo-keyword-faces ()
  "Set ‘org-todo-keyword-faces’ to all different colors."
  (setq org-todo-keyword-faces (oni-org-generate-todo-keyword-faces)))

(defun oni-org-set-tag-faces ()
  "Set ‘org-tag-faces’ to all different colors."
  (setq org-tag-faces (oni-org-generate-tag-faces))
  (org-set-tag-faces 'org-tag-faces org-tag-faces))

(defun oni-org-set-priority-faces ()
  "Set ‘org-priority-faces’ to all different colors."
  (setq org-priority-faces
        (map-merge 'alist org-priority-faces (oni-org-generate-priority-faces))))

;;;###autoload(autoload 'oni-hydra-org/body "oni-org")
(defhydra oni-hydra-org (:color teal :hint nil)
  "
         ^Tasks^                   ^Buffer^                  ^Capture^
^^^^^^------------------------------------------------------------------------
_a_: Show Agenda          _b_: Switch to org buffer  _t_: Note
_c_: Capture new heading  _s_: Save all org buffers  _A_: Appointment
_l_: Store link           ^^                         _j_: Journal entry
^^                                  ^Roam^^^
^^^^^^------------------------------------------------------------------------
_f_: Find note            _i_: Insert note
^^                                ^Document^^^
^^^^^^------------------------------------------------------------------------
_di_: Add inlineimages STARTUP
"
  ("l" org-store-link)
  ("a" org-agenda)
  ("c" org-capture)
  ("b" org-switchb)
  ("s" org-save-all-org-buffers)
  ("t" (org-capture nil "t"))
  ("A" (org-capture nil "a"))
  ("j" (org-capture nil "j"))
  ("f" org-roam-node-find)
  ("i" org-roam-node-insert)
  ("di" oni-org-document-add-inline-images-startup))

(defun oni-org-in-dblock-p ()
  "Non-nil when point belongs to a dynamic block."
  (save-match-data
    (let ((case-fold-search t)
	      (lim-up (save-excursion (outline-previous-heading)))
	      (lim-down (save-excursion (outline-next-heading))))
	  (org-between-regexps-p
	   "^[ \t]*#\\+begin"
	   "^[ \t]*#\\+end"
	   lim-up lim-down))))

(defun oni-org-wrap-region-in-block (block-name beginning end)
  "Create a block BLOCK-NAME and wrap the text between BEGINNING and END in there."
  (interactive "sName: \nr")
  (save-excursion
    (goto-char end)
    (unless (looking-back (rx "\n") nil) (insert "\n"))
    (insert "#+end_" block-name)
    (unless (looking-at (rx "\n")) (insert "\n"))
    (goto-char beginning)
    (unless (looking-back (rx "\n") nil) (insert "\n"))
    (insert "#+begin_" block-name)
    (unless (looking-at (rx "\n")) (insert "\n"))))

;; Create a new archive for each year. This way archives don't keep growing
;; indefinitely and opening the archive doesn't load every single language I've
;; ever used because there are code blocks in there.
(setq org-archive-location (format-time-string "%%s_archive_%Y::"))
(setq org-fold-catch-invisible-edits 'error)
(setq org-clock-in-switch-to-state #'oni-org-maybe-change-todo-state)
(setq org-extend-today-until 2)
(setq org-fontify-whole-heading-line t)
(setq org-fontify-quote-and-verse-blocks t)
(setq org-footnote-auto-adjust t)
(setq org-habit-graph-column 60)
(setq org-hide-emphasis-markers t)
(setq org-hide-macro-markers t)
(setq org-pretty-entities t)
(setq org-return-follows-link t)
(setq org-return-follows-link t)
(setq org-special-ctrl-a/e t)
(setq org-src-fontify-natively t)
(setq org-tags-column -80)
(setq org-tags-exclude-from-inheritance '("project"))
(setq org-tags-sort-function #'string<)
(setq org-use-fast-todo-selection t)
(setq org-use-sub-superscripts '{})

;; Discovered through
;; https://github.com/novoid/dot-emacs/blob/23c28944f1991c636ea71ec7d5c3d266e6dbeb8a/config.org#general-org-mode-settings
(setq org-special-ctrl-k t)

;; Generally, for state updates and such, I like to have all of the notes added
;; into the logbook, but when I want to add a note manually I definitely want it
;; to show up easily seen in the buffer.
(setq org-log-into-drawer t)

(defun oni-org-logging-outside-drawer (func &rest args)
  "Call FUNC with ARGS.
Set ‘org-log-into-drawer’ to nil if we’re trying to take a note,
and not a state update."
  (let ((org-log-into-drawer (not (eql org-log-note-purpose 'note))))
    (apply func args)))

(add-function :around (symbol-function 'org-store-log-note)
              #'oni-org-logging-outside-drawer)

;; Set the maximum indentation level for description lists to 5 (which is the
;; seemingly hardcoded value of the indentation it gets when it goes over
;; ‘org-list-description-max-indent’) so that I don’t get dangling descriptions
;; when my term is 19 characters long.
(setq org-list-description-max-indent 5)

(setq org-default-notes-file (expand-file-name "inbox.org" oni-org-todo-dir))
(setq org-bibtex-autogen-keys t)

(defun oni-org-todo-maybe-hide-body ()
  "Hide the current outline body if ‘org-state’ is a DONE state."
  (when (member org-state org-done-keywords)
    (outline-hide-body)))

(defun oni-org-update-all-dblocks-live ()
  "Call ‘org-update-all-dblocks’ if the current file isn't an archive file."
  (if (not (or (string-suffix-p "_archive" (buffer-file-name))
               (string= "journal.org" (file-name-nondirectory (buffer-file-name)))))
      (org-update-all-dblocks)))

(setq org-todo-keywords
      '((sequence "TODO(t)" "WIP" "WAITING(W@)" "|" "DONE(d!)")
        (sequence "|" "CANCELLED(c@)")))

(add-hook 'org-after-todo-state-change-hook 'oni-org-todo-maybe-hide-body)

(setf (alist-get 'file org-link-frame-setup) 'find-file)

(add-to-list 'org-modules 'org-habit)
(add-to-list 'org-modules 'org-tempo)

(add-to-list 'org-babel-load-languages '(java . t))
(add-to-list 'org-babel-load-languages '(dot . t))
(add-to-list 'org-babel-load-languages '(gnuplot . t))

(add-to-list 'org-structure-template-alist '("el" . "src emacs-lisp"))
(add-to-list 'org-structure-template-alist '("sh" . "src shell"))

(add-hook 'before-save-hook #'oni-org-update-all-dblocks-live)
(add-hook 'org-mode-hook #'oni-org-set-tag-faces)
(add-hook 'org-mode-hook #'oni-org-set-todo-keyword-faces)
(add-hook 'org-mode-hook #'oni-org-set-priority-faces)
(add-hook 'org-mode-hook #'oni-org-set-yasnippet-condition)
(add-hook 'org-mode-hook 'electric-pair-local-mode)
(add-hook 'org-mode-hook 'electric-quote-local-mode)
(add-hook 'org-mode-hook 'flyspell-mode)
(add-hook 'org-mode-hook 'olivetti-mode)
(add-hook 'org-mode-hook 'org-indent-mode)
(add-hook 'org-mode-hook 'org-pretty-table-mode)
(add-hook 'org-mode-hook 'variable-pitch-mode)
(add-hook 'org-mode-hook 'visual-line-mode)
(add-hook 'org-mode-hook 'yas-minor-mode)

(org-edna-mode)

;;;###autoload
(global-set-key (kbd "C-c o") '("Org commands" . oni-hydra-org/body))

;;;###autoload
(global-set-key (kbd "C-<home>") #'oni-org-open-index)

(with-eval-after-load 'org
  (with-eval-after-load 'yasnippet
    (oni-org-snippets-initialize)))

(with-eval-after-load 'org-edna (diminish 'org-edna-mode))

(with-eval-after-load 'org-id
  (setq org-id-link-to-org-use-id 'use-existing))

;;;; Agenda

(defun oni-org-agenda-window-p (_target _action)
  "Check if the current buffer is the agenda buffer."
  (string= (buffer-name) org-agenda-buffer-name))

(defun oni-org-initialize-agenda-category-icons ()
  "Set ‘org-agenda-category-icon-alist’ if it hasn’t already been set."
  (when (and (display-graphic-p)
             (null org-agenda-category-icon-alist))
    (oni-org-set-agenda-category-icons)))

(defun oni-org-set-agenda-category-icons ()
  "Set ‘org-agenda-category-icon-alist’."
  (setq org-agenda-category-icon-alist
        (mapcar (lambda (pair) (list (rx string-start (literal (car pair)) string-end)
                                     (expand-file-name (cdr pair) oni-org-icons-dir)
                                     'svg nil
                                     :height (window-default-font-height)
                                     :ascent 'center))
                '(("task" . "bx-task.svg")
                  ("inbox" . "bxs-inbox.svg")
                  ("email" . "mat-email.svg")
                  ("mail" . "mat-email.svg")
                  ("life" . "mat-one-up.svg")
                  ("feature" . "mat-star-circle-outline.svg")
                  ("work" . "bs-building.svg")
                  ("game" . "bxs-game.svg")
                  ("shopping" . "bx-shopping-bag.svg")
                  ("bug" . "bx-bug.svg")
                  ("idea" . "bxs-bulb.svg")
                  ("article" . "mat-post-outline.svg")
                  ("project" . "bs-kanban.svg")
                  ("ebook" . "bxs-book-content.svg")
                  ("book" . "mat-book-open-variant.svg")
                  ("Morning Cup of Coding" . "bxs-coffee.svg")
                  ("paper" . "mat-note-text-outline.svg")
                  ("question" . "mat-head-question.svg")
                  ("music" . "bxs-music.svg")
                  ("emacs" . "emacs.svg")
                  ("guix" . "guix.svg")
                  ("moving" . "bxs-truck.svg")
                  ("security" . "mat-security.svg")
                  ("website" . "mat-web.svg")
                  ("desktop" . "bx-desktop.svg")
                  ("maint" . "bs-tools.svg")
                  ("comm" . "bs-telephone-fill.svg")
                  ("config" . "bx-cog.svg")
                  ("blog" . "bx-rss.svg")
                  ("writing" . "bxs-pencil.svg")
                  ("code" . "code.svg")
                  ("list" . "list.svg")
                  ("video" . "video-fill.svg")
                  ("album" . "album-fill.svg")))))

(defun oni-org-roam-todo-files ()
  "Collect all files that have TODO items in them."
  (mapcar
   #'car
   (org-roam-db-query
    [:select :distinct file :from nodes :where (= todo $s1)] "TODO")))

(defun oni-org-para-todo-files ()
  "Collect all task files from my PARA repository."
  (delete nil
          (mapcar (lambda (dir)
                    (cond
                     ((string-prefix-p "." (file-name-nondirectory dir)) nil)
                     (t (let ((file-name (expand-file-name "tasks.org" dir)))
                          (and (file-exists-p file-name) file-name)))))
                  (append (directory-files
                           (expand-file-name "documents/exocortex-para/projects" (getenv "HOME"))
                           :full)
                          (directory-files
                           (expand-file-name "documents/exocortex-para/areas" (getenv "HOME"))
                           :full)))))

(setq org-agenda-files (append (list oni-org-todo-main-file)
                               (oni-org-roam-todo-files)
                               (oni-org-para-todo-files)))
(setq org-agenda-tags-todo-honor-ignore-options t)
(setq org-agenda-todo-ignore-scheduled 'future)
(setq org-agenda-restore-windows-after-quit t)
(setq org-agenda-start-with-log-mode t)
(setq org-agenda-window-setup 'only-window)

;; Discovered through
;; https://github.com/novoid/dot-emacs/blob/23c28944f1991c636ea71ec7d5c3d266e6dbeb8a/config.org#general-org-mode-settings
(setq org-agenda-dim-blocked-tasks 'invisible)

(add-hook 'org-mode-hook #'oni-org-initialize-agenda-category-icons)

(add-to-list 'display-buffer-alist
             '(oni-org-agenda-window-p
               display-buffer-in-previous-window
               (inhibit-same-window . t)))

;;;; Capture

(require 'org-capture)

(defconst oni-org-capture-template-directory
  (expand-file-name "capture-templates" oni-org-root)
  "Directory where the template files for ‘org-capture’ are located.")

(defun oni-org-delete-frame-once ()
  "Run `delete-frame'.

After running it once remove it from `org-capture-after-finalize-hook'."
  (delete-frame)
  (remove-hook 'org-capture-after-finalize-hook 'oni-org-delete-frame-once))

(defun oni-org-run-capture-in-dedicated-frame ()
  "Run `org-capture' in a dedicated frame."
  (interactive)
  (with-selected-frame (make-frame '((minibuffer . nil)
                                     (name . "emacs-org-capture")
                                     (width . 80)
                                     (height . 24)))
    (org-capture nil "t")
    (delete-other-windows)
    (set-frame-width nil 80)
    (set-frame-height nil 24)
    (add-hook 'org-capture-after-finalize-hook 'oni-org-delete-frame-once)))

(defun oni-org-get-url-title (url)
  "Load URL and parse out the title."
  (with-current-buffer
      (url-retrieve-synchronously url)
    (unwind-protect
        (when (re-search-forward (rx "<title" (zero-or-more (not ">")) ">") nil t)
          (let ((title-start (point)))
            (when (re-search-forward (rx "</title>") nil t)
              (string-trim (buffer-substring title-start (- (point) 8))))))
      (kill-buffer))))

(defun oni-org-get-url-link (url)
  "Turn URL into an org link."
  (let ((title (oni-org-get-url-title url)))
    (format "[[%s][%s]]" url title)))

(defun org-edna-finder/next-sibling-first-child ()
  "A finder for ‘org-edna’ to find the first child of the next sibling."
  (save-excursion
    (org-back-to-heading t)
    (org-goto-sibling)
    (org-goto-first-child)
    (list (point-marker))))

(defun org-edna-condition/day-of-week? (neg weekday)
  (let ((condition (not (= (string-to-number (format-time-string "%u")) weekday))))
    (when (xor condition neg)
      "Not the right day.")))

(defun org-edna-condition/night-time? (neg)
  "A condition for ‘org-edna’ see if it's what I consider nighttime."
  (let* ((hour (nth 2 (decode-time)))
         (condition (or (> hour 20)
                        (< hour 8))))
    (when (xor condition neg)
      "Too late!")))

(defun org-edna-condition/business-hours? (neg timezone)
  "A condition for ‘org-edna’ to see if it's during regular business hours."
  (let* ((hour (nth 2 (decode-time nil timezone)))
         (condition (> 9 hour 18)))
    (when (xor condition neg)
      (format "Outside of business hours in %s!" timezone))))

;;; Refile

(defun oni-org-refile-to-top ()
  (interactive)
  (let ((org-reverse-note-order t))
    (org-refile)))

;; Set it up so that I can refile easily and still create new nodes when I
;; refile. Include the file in the outline path so that I can refile into them
;; and create top-level headings.
(setq org-refile-use-outline-path 'file
      org-outline-path-complete-in-steps nil
      org-refile-allow-creating-parent-nodes 'confirm
      org-log-refile 'time)

;; Refiling can go to any heading in the current file, any heading in
;; ‘oni-org-todo-main-file', and the top of ‘oni-org-todo-someday-file'.
(setq org-refile-targets '((nil . (:maxlevel . 10))
                           (oni-org-todo-main-file . (:maxlevel . 10))
                           (oni-org-todo-someday-file . (:maxlevel . 1))
                           (oni-org-todo-tickler-file . (:level . 1))))

(define-key org-mode-map (kbd "C-c C-S-w") #'oni-org-refile-to-top)

;;; Export
(require 'ox-html)
(require 'nxml-mode)

;; From https://emacs.stackexchange.com/a/57433
(defcustom oni-org-html-embed-svg nil
  "Embed SVG images.
You can set this variable in Org files with
#+HTML_EMBED_SVG: t
or
#+OPTIONS: html-embed-svg:t"
  :type 'boolean
  :group 'org-export-html)

(cl-pushnew
 '(:html-embed-svg "HTML_EMBED_SVG" "html-embed-svg" oni-org-html-embed-svg)
 (org-export-backend-options (org-export-get-backend 'html)))

(defun oni-org-html-svg-image-embed (fun source attributes info)
  "Make embedding of SVG images possible in org HTML export.
SVG images are embedded if :html-embed-svg is non-nil in the plist INFO.
Otherwise FUN called with SOURCE, ATTRIBUTES, and INFO as arguments.
SOURCE is the file name of the SVG file.
This is an around advice for ‘org-html--svg-image’ as FUN."
  (if (member (plist-get info :html-embed-svg) '("yes" "t" t))
      (with-temp-buffer
        (insert-file-contents source)
        (with-syntax-table nxml-mode-syntax-table
          (while (and (search-forward "<svg" nil t)
                      (nth 8 (syntax-ppss))))
          (delete-region (point-min) (match-beginning 0))
          (buffer-string)))
    (funcall fun source attributes info)))

(with-eval-after-load 'ox-html
  (advice-add 'org-html--format-image :around #'oni-org-html-svg-image-embed)
  ;; These two I've added because when I try to upload text with either of these
  ;; characters to Tekuti I just end up with sending ? for each. This is not an
  ;; issue with org-mode, the generated HTML correctly contains these characters
  ;; verbatim.
  (add-to-list 'org-html-special-string-regexps (cons (rx "“") "&ldquo;"))
  (add-to-list 'org-html-special-string-regexps (cons (rx "”") "&rdquo;")))

;;; Pomodoro

;; Add my current pomodoro time duration so that I can make estimates in
;; Pomodoros like 1p.
(defconst oni-org-pomodoro-duration 25
  "The duration in minutes of a single pomodoro.")

(with-eval-after-load 'org-duration
  (add-to-list 'org-duration-units `("p" . ,oni-org-pomodoro-duration))
  (org-duration-set-regexps))

;;; Projects

(defun oni-org-pick-project (property)
  (when (string= property "PROJECT")
    (org-map-entries (lambda () (concat (buffer-name) ":" (mapconcat (lambda (x) x) (org-get-outline-path t) ":"))) "CATEGORY=\"project\""
                     org-agenda-files)))

(defun oni-org-link-project (value)
  (let* ((split-value (split-string value ":"))
         (marker (org-find-olp split-value)))
    (save-excursion
      (with-current-buffer (marker-buffer marker)
        (goto-char marker)
        (format "[[id:%s][%s]]" (org-id-get-create) (car (last split-value)))))))

(add-to-list 'org-properties-postprocess-alist '("PROJECT" . oni-org-link-project))

(add-hook 'org-property-allowed-value-functions #'oni-org-pick-project)

(defun oni-org-collect-project-references (heading-id)
  (let ((files (org-add-archive-files (list (buffer-file-name))))
        backlinks)
    (save-excursion
      (mapc (lambda (file)
              (with-current-buffer (or (get-file-buffer file)
                                       (progn
                                         (find-file-noselect file)
                                         (get-file-buffer file)))
                (goto-char (point-min))
                (while (re-search-forward
                        (rx (or (seq "[[id:" (literal heading-id) "]")
                                (seq "#" (literal heading-id) "]")))
                        nil t)
                  (unless (or (oni-org-in-dblock-p)
                              (oni-org-at-origin-property-p))
                    (let ((components (org-heading-components)))
                      (push `((done . ,(and (org-entry-is-done-p) t))
                              (position . ,(point))
                              (title . ,(replace-regexp-in-string (rx (zero-or-more whitespace)
                                                                      "[" (or (seq (zero-or-more digit) "%")
                                                                              (seq (zero-or-more digit) "/" (zero-or-more digit)))
                                                                      "]" eol)
                                                                  "" (nth 4 components)))
                              (file . ,file))
                            backlinks))))))
            files))
    backlinks))

(defun oni-org-linkify-backlink (link)
  (format "- [%s] [[%s*%s][%s]]"
          (if (alist-get 'done link) "X" " ")
          (let ((file-name (alist-get 'file link)))
            (if (string-suffix-p "_archive" file-name t)
                (format "file:%s::" (alist-get 'file link))
              ""))
          (alist-get 'title link)
          (alist-get 'title link)))

(defun oni-org-link= (a b)
  (= (alist-get 'position a)
     (alist-get 'position b)))

(defun oni-org-link< (a b)
  (< (alist-get 'position a)
     (alist-get 'position b)))

(defun oni-org-dblock-write-project-steps (_params)
  "Generate back-links to org headings."
  (let* ((current-heading-id
          (let ((properties (org-entry-properties)))
            (or (alist-get "CUSTOM_ID" properties nil nil #'string=)
                (org-id-get-create))))
         (backlinks (and (not (null current-heading-id))
                         (oni-org-collect-project-references current-heading-id))))
    (insert (string-join
             (mapcar #'oni-org-linkify-backlink
                     (sort (seq-uniq backlinks #'oni-org-link=) #'oni-org-link<))
             "\n"))
    (org-update-statistics-cookies nil)))

(defun oni-org-insert-project-steps ()
  "Create a dynamic block capturing the steps in a project."
  (interactive)
  (org-create-dblock '(:name "oni-project-steps"))
  (org-update-dblock))

(defalias 'org-dblock-write:oni-project-steps 'oni-org-dblock-write-project-steps)
(org-dynamic-block-define "oni-project-steps" #'oni-org-insert-project-steps)

;;; Moving subtrees

(defun oni-org-move-subtree (target placement)
  "Move the subtree at point to TARGET and place it at PLACEMENT.

TARGET should be a point or a marker in the current buffer.

PLACEMENT should be a symbol. If PLACEMENT is above, it'll be
placed above TARGET. Otherwise it will be placed below it."
  (interactive
   (list (let ((org-refile-targets '((nil :maxlevel . 1)))
               (org-refile-use-outline-path nil))
           (org-refile-get-location "Move subtree to:"))
         (intern (completing-read "Above / Below: " '(above below) nil t))))
  (save-excursion
    (let ((heading-level (car (org-heading-components)))
          (marker (copy-marker (nth 3 target)))
          (this-command t))
      (org-cut-subtree)
      (goto-char marker)
      (unless (eq placement 'above)
        (org-forward-heading-same-level 1)
        (when (= (point) (marker-position marker))
          (goto-char (point-max))))
      (org-paste-subtree heading-level nil nil t))))

;;; Pomodoro dynamic block

(defun oni-org-dblock-write-pomodoro-overview (params)
  (let* ((date (plist-get params :date))
         (info (org-map-entries (lambda ()
                                  (let ((components (org-heading-components)))
                                    (list (cons 'done (and (org-entry-is-done-p) t))
                                          (cons 'title (nth 4 components))
                                          (cons 'poms (length (oni-org-pomodoro-times-for-date
                                                               (org-parse-time-string date))))
                                          (cons 'id (org-id-get-create)))))
                                (format "TODO=\"NEXT\"|CLOSED>=\"<%s 0:00>\"+CLOSED<=\"<%s 23:59>\""
                                        date date)
                                'agenda)))
    (insert
     (string-trim-right
      (apply #'concat "| | Task | Effort |\n"
             "|-+------+--------|\n"
             "| | <60> |        |\n"
             (mapcar (lambda (itm)
                       (let ((emphasis (if (alist-get 'done itm) "+" ""))
                             (title (alist-get 'title itm)))
                         (format "| | %s[[id:%s][%s]]%s | %s |\n"
                                 emphasis
                                 (alist-get 'id itm)
                                 title
                                 emphasis
                                 (make-string (alist-get 'poms itm) ?X))))
                     info))))
    (org-table-align)
    (org-table-shrink)))

(defun oni-org-insert-pomodoro-overview ()
  "Create a dynamic block showing the Pomodoro overview for today."
  (interactive)
  (org-create-dblock `(:name "oni-pomodoro-overview"
                       :date ,(format-time-string "%Y-%m-%d")))
  (org-update-dblock))

(defalias 'org-dblock-write:oni-pomodoro-overview 'oni-org-dblock-write-pomodoro-overview)
(org-dynamic-block-define "oni-pomodoro-overview" #'oni-org-insert-pomodoro-overview)

(defun oni-org-increment-property (property)
  (interactive
   (list (org-read-property-name)))
  (let ((value (string-to-number (or (org-entry-get (point) property) "0"))))
    (org-set-property property (number-to-string (1+ value)))))

(add-to-list 'org-log-note-headings
             (cons 'pomodoro-finished "Finished a pomodoro on %t"))
(add-to-list 'org-log-note-headings
             (cons 'pomodoro-planned "Planned to complete pomodoros on %d"))

(defun oni-org-pomodoro-add-finished-note ()
  (interactive)
  (org-add-log-setup 'pomodoro-finished nil nil 'time))

(defun oni-org-pomodoro-add-planned-note ()
  (interactive)
  (org-add-log-setup 'pomodoro-planned nil nil 'time))

(defun oni-org-pomodoro-times ()
  (let ((entry-beginning (org-entry-beginning-position))
        (entry-end (org-entry-end-position))
        results)
    (save-excursion
      (goto-char entry-beginning)
      (save-match-data
        (when (re-search-forward org-logbook-drawer-re entry-end nil)
          (let ((logbook-beginning (match-beginning 0))
                (logbook-end (match-end 0)))
            (goto-char logbook-beginning)
            (while (re-search-forward
                    (rx "Finished a pomodoro on "
                        (group "[" (one-or-more (not "]")) "]"))
                    logbook-end t)
              (push (org-parse-time-string (match-string 1)) results))))))
    results))

(defun oni-org-pomodoro-times-for-date (date)
  (let ((day (decoded-time-day date))
        (month (decoded-time-month date))
        (year (decoded-time-year date)))
    (seq-filter (lambda (time) (and (= (decoded-time-day time) day)
                                    (= (decoded-time-month time) month)
                                    (= (decoded-time-year time) year)))
                (oni-org-pomodoro-times))))

;;; Archive Management

(defun oni-org-archive-old-tasks ()
  "Archive tasks in all agenda files that were closed before the current month."
  (interactive)
  (let ((match (format-time-string "CLOSED<\"<%Y-%m-01>\"")))
    (mapc (lambda (p)
            (goto-char p)
            (org-archive-subtree))
          (reverse (org-map-entries #'point match 'agenda)))))

;;; Inbox management

(defun oni-org-should-dump-tickler-p ()
  (with-current-buffer (find-file-noselect oni-org-todo-tickler-file)
    (goto-char (point-min))
    (search-forward "#+last-dumped: ")
    (let ((dumped-date (org-timestamp-to-time (org-timestamp-from-string (buffer-substring-no-properties (point) (line-end-position)))))
          (current-date (org-timestamp-to-time (org-timestamp-from-string (format-time-string "[%Y-%m-%d]")))))
      (time-less-p dumped-date current-date))))

(defun oni-org-update-tickler-dumped-date ()
  (with-current-buffer (find-file-noselect oni-org-todo-tickler-file)
    (goto-char (point-min))
    (search-forward "#+last-dumped: ")
    (delete-region (point) (line-end-position))
    (insert (format-time-string "[%Y-%m-%d]"))))

(defun oni-org-dump-tickler-1 ()
  (with-current-buffer (find-file-noselect oni-org-todo-tickler-file)
    (save-excursion
      (goto-char (point-min))
      (org-forward-heading-same-level 1)
      (let* ((element (org-element-at-point-no-context))
             (element-title (org-element-property :raw-value element))
             (contents-begin (org-element-property :contents-begin element))
             (contents-end (org-element-property :contents-end element)))
        (when contents-begin
          (let ((text (buffer-substring-no-properties contents-begin contents-end)))
            (delete-region contents-begin contents-end)
            (with-temp-buffer
              (insert text)
              (org-mode)
              (org-map-entries 'org-promote-subtree)
              (setq text (buffer-substring-no-properties (point-min) (point-max))))
            (with-current-buffer (find-file-noselect oni-org-todo-inbox-file)
              (save-excursion
                (let ((max-point (point-max)))
                  (goto-char max-point)
                  (insert text)
                  (goto-char max-point))))))
        (if (string-match-p (rx (one-or-more digit)) element-title)
            (progn
              (dotimes (_ 31)
                (org-move-subtree-down))
              (unless (string= element-title (format-time-string "%-d"))
                (oni-org-dump-tickler-1)))
          (dotimes (_ 42)
            (org-move-subtree-down))
          (oni-org-dump-tickler-1))))))

(defun oni-org-dump-tickler ()
  (interactive)
  (when (oni-org-should-dump-tickler-p)
    (oni-org-dump-tickler-1)
    (oni-org-update-tickler-dumped-date)))

(defun oni-org-run-through-inbox ()
  (interactive)
  (oni-org-dump-tickler)
  (catch 'done
    (while t
      (find-file oni-org-todo-inbox-file)
      (goto-char (point-min))
      (org-forward-heading-same-level 1)
      (when (not (org-at-heading-p))
        (throw 'done t))
      (org-fold-save-outline-visibility nil
        (outline-show-entry)
        (org-narrow-to-subtree)
        (unwind-protect
            (catch 'continue
              (while t
                (let ((choice (read-multiple-choice
                               "Which action: "
                               '((?r "Refile" "Refile heading to a different place")
                                 (?R "Refile to top" "Refile heading to a different place, placing the note at the top of the heading")
                                 (?a "Archive" "Archive heading")
                                 (?d "Remind me later" "Move it into the tickler file")
                                 (?t "Todo" "Change todo keyword")
                                 (?T "Tag" "Change tags")
                                 (?q "Quit" "Stop going through")))))
                  (condition-case nil
                      (cl-case (car choice)
                        (?r (org-refile)
                            (throw 'continue t))
                        (?R (let ((org-reverse-note-order t))
                              (org-refile))
                            (throw 'continue t))
                        (?a (org-archive-subtree-default)
                            (throw 'continue t))
                        (?d (let ((org-refile-targets `((,oni-org-todo-tickler-file :maxlevel . 10))))
                              (org-refile))
                            (throw 'continue t))
                        (?t (org-todo))
                        (?T (org-set-tags-command))
                        (?q (throw 'done t)))
                    (quit nil)))))
          (widen)
          (delete-blank-lines))))))

(defun oni-org-clock+post-drawer ()
  (if (and (markerp org-clock-hd-marker)
		   (marker-buffer org-clock-hd-marker))
	  (progn (set-buffer (marker-buffer org-clock-hd-marker))
		     (org-capture-put-target-region-and-position)
		     (widen)
		     (goto-char org-clock-hd-marker)
             (let ((end (org-entry-end-position)))
               (while (search-forward ":END:" end t))))
	(user-error "No running clock that could be used as capture target")))

(defun init-find-weekly-review-file ()
  (interactive)
  (find-file (format-time-string "u:/documents/gtd/weekly-reviews/%Y-%W.org"))
  (if (= (point-min) (point-max))
      (progn
        (insert (format-time-string "#+TITLE: Weekly Review Report for Week %-W %Y\n"))
        (insert "\n")
        (insert "See [[file:u:/documents/gtd/checklists/weekly-review.org][Weekly Review Checklist]]\n")
        (insert "\n"))
    (goto-char (point-min))))

;;; Add face to file links that show file doesn't exist.

(defface oni-org-link-nonexistent-file
  '((t :inherit error :underline t :weight regular))
  "Face to display links that point to nonexistent files in.")

(defun oni-org-file-face-selector (path)
  "Return a different face based on whether PATH exists or not.
When PATH exists just return the face ‘org-link’ as usual,
otherwise return ‘oni-org-link-nonexistent-file’."
  (if (file-exists-p path)
      'org-link
    'oni-org-link-nonexistent-file))

(org-link-set-parameters "file" :face #'oni-org-file-face-selector)

;;; Automatically hide code blocks that specify they should be hidden.
;; Inspired by
;; https://emacs.stackexchange.com/questions/44914/choose-individual-startup-visibility-of-org-modes-source-blocks

(defun oni-org-hide-hidden-code-blocks ()
  "Hide any code blocks that have been marked as hidden.
This is done by adding a ‘:hidden t’ header argument to the code block."
  (interactive)
  (org-block-map
   (lambda ()
     (let ((element (org-element-at-point)))
       (when (and (equal (org-element-type element) 'src-block)
                  (map-elt (nth 2 (org-babel-get-src-block-info)) :hidden))
         (org-fold-hide-block-toggle t nil element))))))

(add-hook 'org-mode-hook #'oni-org-hide-hidden-code-blocks)

;;; Agenda commands and capture templates

(defun oni-org--center-align (text)
  "Return the same TEXT, but with enough space added in front to center align it."
  (format "%s%s"
          (propertize " " 'display `((space :align-to (- ,(/ (window-width) 2)
                                                         ,(/ (length text) 2)))))
          text))

(defmacro oni-org--map-put (collection key value)
  "The result of ‘(setf (map-elt ...) ...)’ on a list.
Trying to byte-compile the above form doesn't work at the moment.
This is a temporary hack to make sure I don't have to repeat this
same code all the time."
  (declare (indent 2))
  (let ((key-name (gensym))
        (value-name (gensym)))
    `(let ((,key-name ,key)
           (,value-name ,value))
       (condition-case nil
           (with-no-warnings
             (map-put! ,collection ,key-name ,value-name nil))
         (map-not-inplace
          (setq ,collection
                (map-insert ,collection ,key-name ,value-name))
          ,value-name)))))

(defvar oni-org--capture-D-date nil)
(oni-org--map-put org-capture-templates "D"
  '("A DONE item for my to-done list." entry (file oni-org-todo-main-file) "* DONE %?
CLOSED: %(setq oni-org--capture-D-date (format-time-string (org-time-stamp-format t t) (org-read-date t t nil \"Date: \")))
:PROPERTIES:
:CREATED:  %(progn oni-org--capture-D-date)
:END:
:LOGBOOK:
- State \"DONE\"       from \"TODO\"       %(progn oni-org--capture-D-date)
:END:"
    :after-finalize (lambda () (setq oni-org--capture-D-date nil))))

(oni-org--map-put org-capture-templates "t"
  '("A simple TODO item." entry (file "") "* TODO %?
:PROPERTIES:
:CREATED:  %U
:END:"))

(oni-org--map-put org-capture-templates "U"
  '("A TODO capture from the browser." entry (file "") "* TODO %:description
:PROPERTIES:
:CREATED:  %U
:END:

%:link"
    :immediate-finish t))

;;; Mastodon post dynamic block

(defun oni-org-dblock-write-mastodon-post (params)
  (let* ((url (url-generic-parse-url (map-elt params :url)))
         (status-id (car (last (split-string (url-filename url) "/")))))
    (setf (url-filename url) (format "/api/v1/statuses/%s" status-id))
    (let ((json (with-current-buffer (url-retrieve-synchronously url)
                  (goto-char (point-min))
                  (search-forward "\n\n")
                  (json-parse-buffer))))
      (insert (with-temp-buffer
                (insert (map-elt json "content"))
                (let ((dom (libxml-parse-html-region (point-min) (point-max))))
                  (erase-buffer)
                  (insert "#+begin_quote")
                  (let ((start (point)))
                    (shr-insert-document dom)
                    (forward-char -1)
                    (insert " ---" (map-elt (map-elt json "account") "display_name"))
                    (org-escape-code-in-region start (point))
                    (save-excursion
                      (goto-char start)
                      (delete-all-space)
                      (insert "\n"))
                    (let ((fill-column (point-max)))
                      (fill-region start (point)))))
                (forward-char)
                (insert "#+end_quote")
                (buffer-string))))))

(defun oni-org-insert-mastodon-post (url)
  "Create a dynamic block showing a Mastodon post from URL."
  (interactive "MURL: ")
  (org-create-dblock `(:name "oni-mastodon-post" :url ,url))
  (org-update-dblock))

(defalias 'org-dblock-write:oni-mastodon-post 'oni-org-dblock-write-mastodon-post)
(org-dynamic-block-define "oni-mastodon-post" #'oni-org-insert-mastodon-post)

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