;;; my-org.el -- Extensions for org -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation.

;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))

;; This file is part of dotfiles.

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

;; dotfiles 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 Affero General
;; Public License for more details.

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

;;; Commentary:

;; Extensions for org.

;;; Code:


(require 'org)

;;; org mode
(defun my-org-open-shell-at-attach-dir ()
  (interactive)
  (require 'my-prog)
  (my-shell-with-directory (concat (org-attach-dir-get-create) "/")))

(defun my-org-links-in-entry ()
  "Get all link urls in an entry"
  (save-excursion
    (org-back-to-heading t)
    (let (links
	        (end (save-excursion (outline-next-heading) (point))))
	    (while (re-search-forward org-link-any-re end t)
	      (push
         (org-unbracket-string "<" ">"
					 (or
						;; [[target][desc]]
						(match-string-no-properties 2)
						;; plain link or <...>
						(match-string-no-properties 0)))
         links))
      links)))

(defun my-org-http-s-links-in-entry ()
  "Get all http(s) urls in an entry"
  (seq-filter (lambda (link)
                (string-prefix-p
                 "http"
                 (progn (string-match org-link-types-re link)
                        (match-string 1 link))))
              (my-org-links-in-entry)))

(defun my-org-insert-date-range (inactive)
  "Insert two dates to form an active date range.

With a prefix, insert inactive dates.
"
  (interactive "P")
  (org-time-stamp nil inactive)
  (insert "--")
  (org-time-stamp nil inactive))

(defun my-org-follow-link-after ()
  (when (eq major-mode 'mhtml-mode)
    (browse-url-of-buffer)))

(defvar my-org-edit-src-was-live-window nil
  "Set to non-nil by `my-org-edit-src-before-exit' if the edit src
buffer was a live window.")

(defun my-org-edit-src-before-exit ()
  "A :before advice for org-edit-src-exit."
  (delete-trailing-whitespace)
  (setq my-org-edit-src-was-live-window (get-buffer-window (current-buffer))))

(defun my-org-element-block-p (element)
  "Returns t if ELEMENT is an org block."
  (memq (org-element-type element)
			  '(center-block comment-block dynamic-block
					             example-block export-block quote-block
					             special-block src-block verse-block)))

(defun my-org-edit-src-after-exit ()
  "An :after advice for `org-edit-src-exit'.

If the block is empty, remove it.
Otherwise deactivate mark and move point to after the block."
  ;; Only proceed if buffer is in a live window, needed to avoid
  ;; indenting triggering this function
  (when my-org-edit-src-was-live-window
    (deactivate-mark)
    (let ((element (org-element-at-point)))
      (cl-assert (my-org-element-block-p element))
      (if (string-empty-p (org-element-property :value element))
          (delete-region (org-element-property :begin element)
                         (org-element-property :end element))
        (goto-char (org-element-property :end element))))))

;; navigation
(defun my-org-jump-to-last-visible-child ()
  "Goto the last visible child."
  (interactive)
  (let (level (pos (point)) (re org-outline-regexp-bol))
    (when (ignore-errors (org-back-to-heading t))
      (setq level (outline-level))
      (forward-char 1)
      (while (and (re-search-forward re nil t) (> (outline-level) level))
	      (when (and (= (outline-level) (1+ level))
		               (not (get-char-property (point) 'invisible)))
	        (setq pos (match-beginning 0)))))
    (goto-char pos)))

(defun my-org-entry-toggle-drawer-visibility ()
  (interactive)
  (save-excursion
    (save-restriction
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (while (re-search-forward "^\\ *:[A-Z]+:\\ *$" nil t)
        (org-hide-drawer-toggle)
        (re-search-forward "^\\ *:END:\\ *$" nil t)))))

(defun my-org-beginning-of-line-or-indent ()
  "Move to org beginning of line, or indentation"
  (interactive)
  (if (bolp)
      (back-to-indentation)
    (org-beginning-of-line)))

(defun my-org-kill-line (&optional arg)
  "Call `org-kill-line', or `my-kill-forward' with a prefix arg."
  (interactive "P")
  (if arg
      (my-kill-forward)
    (org-kill-line)))

(defun my-org-kill-line-backwards (&optional arg)
  "Kill backwards in an org way, or `my-kill-backward' with a prefix arg."
  (interactive "P")
  (if arg
      (my-kill-backward)
    (if (bolp)
        (delete-char -1)
      (kill-region
       (save-excursion (my-org-beginning-of-line-or-indent) (point))
       (point)))))

(defvar my-shell-buffer-list nil
  "List of default org notes file buffers.")

(defun my-org-open-or-cycle-notes (arg)
  "Open default notes file.

Switch to the first buffer with the notes file that's not in a
live window, or find the notes file.

If repeated, cycle through indirect buffers of the default notes.

With a prefix ARG, creates a new indirect buffer of the default
notes file."
  (interactive "P")
  (if arg
      (with-current-buffer (find-file-noselect org-default-notes-file)
        (clone-indirect-buffer nil t)
        (setq my-notes-buffer-list
              (setq-filter 'my-buffer-with-same-base-p
                           (buffer-list))))
    (if (eq last-command 'my-org-open-or-cycle-notes)
        (progn
          (setq my-notes-buffer-list
                (my-list-cycle my-notes-buffer-list))
          (switch-to-buffer (car my-notes-buffer-list)))
      (let ((buffer
             (find-file-noselect org-default-notes-file)))
        (with-current-buffer buffer
          (setq my-notes-buffer-list
                (seq-filter 'my-buffer-with-same-base-p (buffer-list))))
        ;; Find first buffer that is not in a live window. If no such
        ;; buffer exists, fall back to `find-file-noselect'.
        (setq buffer
              (or
               (seq-find
                (lambda (buffer)
                  (not (my-buffer-live-window-p buffer)))
                my-notes-buffer-list)
               (find-file-noselect org-default-notes-file)))
        (while (not (eq buffer (car my-notes-buffer-list)))
          (setq my-notes-buffer-list
                (my-list-cycle my-notes-buffer-list))))
      (switch-to-buffer (car my-notes-buffer-list))
      )))

;; links
(defun my-org-substitute-gnus-link-after-archiving ()
  "Fix a captured gnus article link after they've been archived"
  (interactive)
  (when (org-in-regexp org-link-bracket-re)
    ;; We do have a link at point, and we are going to edit it.
    (save-excursion
      (let ((remove (list (match-beginning 0) (match-end 0)))
            (desc (when (match-end 2) (match-string-no-properties 2)))
            (link (match-string-no-properties 1))
            (target (alist-get 'archive my-gnus-group-default-targets))
            (new-link))
        (pcase-dolist (`(,re . ,info) my-gnus-group-alist)
          (when (and (string-match re link)
                     (alist-get 'archive info))
            (setq target (alist-get 'archive info))))
        (setq new-link
	            (replace-regexp-in-string "/.*?#" (format "/%s#" target)
                                        link))
        (apply #'delete-region remove)
        (insert (org-link-make-string new-link desc))
        (sit-for 0)))))

;; editing heading
(defun my-org-orgzly-merge-link ()
  "Fixes orgzly entries with links separated from headlines.
Find the first link in the entry, and add that to the headline
title, and remove the body."
  (interactive)
  (save-restriction
    (save-excursion
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (forward-line)
      (when (re-search-forward org-link-any-re)
	      (let ((link (buffer-substring-no-properties
		                 (match-beginning 0) (match-end 0)))
              (unused (replace-match "" nil))
	            (desc (org-entry-get (point) "ITEM"))
              (title-loc))
          (goto-char (point-min))
          (search-forward desc nil t)
          (setq title-loc (match-beginning 0))
          (replace-match "" nil)
          (while (search-forward desc nil t) (replace-match "" nil))
	        (goto-char title-loc)
	        (insert (org-link-make-string link desc))))))
  (my-org-node-flush-empty-lines))

(defun my-org-node-flush-empty-lines ()
  (save-restriction
    (save-excursion
      (org-narrow-to-subtree)
      (flush-lines "^$"))))

(defun my-org-element-contents-at-point ()
  (let ((element (org-element-at-point)))
    (buffer-substring-no-properties
     (org-element-property :contents-begin element)
     (org-element-property :contents-end element))))


(defun my-org-append-subheading (arg)
	"Append a subheading as a first child, or with an arg as a last child."
	(interactive "P")
	(if arg
			(org-insert-subheading '(4))
		(let ((required-level (1+ (or (org-current-level) 0))))
			(org-show-children)
			(org-next-visible-heading 1)
			(org-insert-subheading nil)
			(while (> (org-current-level) required-level)
				(org-promote-subtree))
			(while (< (org-current-level) required-level)
				(org-demote-subtree)))))

;; copy a link
;;; fixme: do we still need this?
(defun my-org-copy-link-at-point ()
  (interactive)
  (let ((link (my-org-link-at-point)))
    (if link
        (progn
          (kill-new link)
          (message "Copied: %s" link))
      (message "Point is not an org link!"))))

(defun my-org-link-at-point ()
  (interactive)
  (when (org-in-regexp org-link-any-re)
    (org-unbracket-string "<" ">"
			(or
			 ;; [[target][desc]]
			 (match-string-no-properties 2)
			 ;; plain link or <...>
			 (match-string-no-properties 0)))))

(defun my-org-store-link-and-return ()
  "run org-goto to select a heading, stores its link and insert it."
  (interactive)
  (save-restriction
    (widen)
    (save-excursion
      (call-interactively 'org-goto)
      (call-interactively 'org-store-link)))
  (call-interactively 'org-insert-last-stored-link))

;; overload org-insert-all-links (do we need autoload as in the original file?)
(defun my-org-insert-all-links (arg &optional pre post)
  "Insert all links in `org-stored-links'.
When a universal prefix, do not delete the links from `org-stored-links'.
When `ARG' is a number, insert the last N link(s).
`PRE' and `POST' are optional arguments to define a string to
prepend or to append."
  (interactive "P")
  (let ((org-link-keep-stored-after-insertion (equal arg '(4)))
	      (links (copy-sequence org-stored-links))
	      (pr (or pre "- "))
	      (po (or post "\n"))
	      (cnt 1) l)
    (if (null org-stored-links)
	      (message "No link to insert")
      (while (and (or (listp arg) (>= arg cnt))
		              (setq l (if (listp arg)
			                        (pop links)
			                      (pop org-stored-links))))
	      (setq cnt (1+ cnt))
	      (insert pr)
	      (org-insert-link nil (car l) (or (cadr l) ""))
	      (insert po)))))

;; overload org-open-at-point-global to fix bug property link not
;; opened in external browser (2d0e61c8-da74-417e-8ccd-c4099ccd88d8)
(defun my-org-open-at-point-global (&optional arg)
  "Follow a link or a time-stamp like Org mode does.
Also follow links and emails as seen by `thing-at-point'.
This command can be called in any mode to follow an external
link or a time-stamp that has Org mode syntax.  Its behavior
is undefined when called on internal links like fuzzy links.
Raise a user error when there is nothing to follow."
  (interactive "P")
  (let ((tap-url (thing-at-point 'url))
	      (tap-email (thing-at-point 'email)))
    (cond ((org-in-regexp org-link-any-re)
	         (org-link-open-from-string (match-string-no-properties 0) arg))
	        ((or (org-in-regexp org-ts-regexp-both nil t)
	             (org-in-regexp org-tsr-regexp-both nil t))
	         (org-follow-timestamp-link))
	        (tap-url (org-link-open-from-string tap-url))
	        (tap-email (org-link-open-from-string
		                  (concat "mailto:" tap-email)))
	        (t (user-error "No link found")))))

;; overload org-refile-get-targets
(defun my-org-refile-get-targets (&optional default-buffer)
  "Produce a table with refile targets."
  (let ((case-fold-search nil)
	      ;; otherwise org confuses "TODO" as a kw and "Todo" as a word
	      (entries (or org-refile-targets '((nil . (:level . 1)))))
	      targets tgs files desc descre)
    (message "Getting targets...")
    (with-current-buffer (or default-buffer (current-buffer))
      (dolist (entry entries)
	      (setq files (car entry) desc (cdr entry))
	      (cond
	       ((null files) (setq files (list (current-buffer))))
	       ((eq files 'org-agenda-files)
	        (setq files (org-agenda-files 'unrestricted)))
	       ((and (symbolp files) (fboundp files))
	        (setq files (funcall files)))
	       ((and (symbolp files) (boundp files))
	        (setq files (symbol-value files))))
	      (when (stringp files) (setq files (list files)))
	      (cond
	       ((eq (car desc) :tag)
	        (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":")))
	       ((eq (car desc) :todo)
	        (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]")))
	       ((eq (car desc) :regexp)
	        (setq descre (cdr desc)))
	       ((eq (car desc) :level)
	        (setq descre (concat "^\\*\\{" (number-to-string
					                                (if org-odd-levels-only
					                                    (1- (* 2 (cdr desc)))
					                                  (cdr desc)))
			                         "\\}[ \t]")))
	       ((eq (car desc) :maxlevel)
	        (setq descre (concat "^\\*\\{1," (number-to-string
					                                  (if org-odd-levels-only
						                                    (1- (* 2 (cdr desc)))
					                                    (cdr desc)))
			                         "\\}[ \t]")))
	       (t (error "Bad refiling target description %s" desc)))
	      (dolist (f files)
	        (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f))
	          (or
	           (setq tgs (org-refile-cache-get
                        (buffer-file-name
                         (when (bufferp f) (buffer-base-buffer f)))
                        descre))
	           (progn
	             (when (bufferp f)
		             (setq f (buffer-file-name (buffer-base-buffer f))))
	             (setq f (and f (expand-file-name f)))
	             (when (eq org-refile-use-outline-path 'file)
		             (push (list (and f (file-name-nondirectory f)) f nil nil) tgs))
	             (when (eq org-refile-use-outline-path 'buffer-name)
		             (push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs))
	             (when (eq org-refile-use-outline-path 'full-file-path)
		             (push (list (and (buffer-file-name (buffer-base-buffer))
                                  (file-truename (buffer-file-name (buffer-base-buffer))))
                             f nil nil) tgs))
	             (org-with-wide-buffer
		            (goto-char (point-min))
		            (setq org-outline-path-cache nil)
		            (while (re-search-forward descre nil t)
		              (beginning-of-line)
		              (let ((case-fold-search nil))
		                (looking-at org-complex-heading-regexp))
		              (let ((begin (point))
			                  (heading (match-string-no-properties 4)))
		                (unless (or (and
				                         org-refile-target-verify-function
				                         (not
				                          (funcall org-refile-target-verify-function)))
				                        (not heading))
		                  (let ((re (format org-complex-heading-regexp-format
					                              (regexp-quote heading)))
			                      (target
			                       (if (not org-refile-use-outline-path) heading
			                         (mapconcat
				                        #'identity
				                        (append
				                         (pcase org-refile-use-outline-path
				                           (`file (list
                                           (and (buffer-file-name (buffer-base-buffer))
                                                (file-name-nondirectory
                                                 (buffer-file-name (buffer-base-buffer))))))
				                           (`full-file-path
				                            (list (buffer-file-name
					                                 (buffer-base-buffer))))
				                           (`buffer-name
				                            (list (buffer-name
					                                 (buffer-base-buffer))))
				                           (_ nil))
				                         (mapcar (lambda (s) (replace-regexp-in-string
						                                          "/" "\\/" s nil t))
					                               (org-get-outline-path t t)))
				                        "/"))))
			                  (push (list target f re (org-refile-marker (point)))
			                        tgs)))
		                (when (= (point) begin)
		                  ;; Verification function has not moved point.
		                  (end-of-line)))))))
	          (when org-refile-use-cache
	            (org-refile-cache-put tgs (buffer-file-name) descre))
	          (setq targets (append tgs targets))))))
    (message "Getting targets...done")
    (delete-dups (nreverse targets))))

;; shadow org-insert-last-stored-link (do not insert \n at the end)
(defun my-org-insert-last-stored-link (arg)
  "Insert the last link stored in `org-stored-links'."
  (interactive "p")
  (org-insert-all-links arg "" ""))

(defun my-org-info-open-new-window (path)
  "Open info in a new buffer"
  (my-select-new-window-matching-mode 'Info-mode)
  (org-info-follow-link path))

(defun my-org-rt-open-new-window (path)
  "Open rt in a new buffer"
  (my-select-new-window-matching-mode 'rt-liber-browser-mode)
  (rt-org-open path))

;; fix org src overlay face
(defun my-org-src--make-source-overlay (beg end edit-buffer)
  "Create overlay between BEG and END positions and return it.
EDIT-BUFFER is the buffer currently editing area between BEG and
END."
  (let ((overlay (make-overlay beg end)))
    (overlay-put overlay 'face 'region)
    (overlay-put overlay 'edit-buffer edit-buffer)
    (overlay-put overlay 'help-echo
		             "Click with mouse-1 to switch to buffer editing this segment")
    (overlay-put overlay 'face 'region)
    (overlay-put overlay 'keymap
		             (let ((map (make-sparse-keymap)))
		               (define-key map [mouse-1] 'org-edit-src-continue)
		               map))
    (let ((read-only
	         (list
	          (lambda (&rest _)
	            (user-error
	             "Cannot modify an area being edited in a dedicated buffer")))))
      (overlay-put overlay 'modification-hooks read-only)
      (overlay-put overlay 'insert-in-front-hooks read-only)
      (overlay-put overlay 'insert-behind-hooks read-only))
    overlay))

(defun my-org-copy-property-value (name)
  (interactive
   (list (completing-read "Copy property: " (org-entry-properties))))
  (let ((value (org-entry-get (point) name)))
    (kill-new value)
    (message "Copied %s" value)))

(defvar my-org-common-properties nil
  "Property list for completion when setting the property of an org node, to
  avoid scanning the whole notes.")

(defun my-org-set-common-property ()
  (interactive)
  (let* ((property
          (completing-read "Which property to set: "
                           my-org-common-properties))
         (value
          (org-read-property-value property)))
    (org-set-property property value)))

(defun my-org-copy-src-block-at-point ()
  (interactive)
  (when (org-in-src-block-p)
    (kill-new (nth 1 (org-babel-get-src-block-info t)))
    (message "org src block copied!")))
(defun my-org-in-or-at-block-p ()
  (or (org-at-block-p)
      (org-in-block-p '("example" "source" "export"
                        "center" "quote" "verse"))))
(defun my-org-copy-block-at-point ()
  (interactive)
  (save-excursion
    (unless (org-at-block-p)
      (org-previous-block 1)
      (let ((element (org-element-at-point)))
        (kill-new (or
                   (org-element-property :value element)
                   (buffer-substring
                    (org-element-property :contents-begin element)
                    (org-element-property :contents-end element))))
        (message "org block copied!")))))

;; clock save timer doesn't seem to be working
(defun my-org-clock-maybe-save ()
  (when (equal major-mode 'org-mode)
    (org-clock-save)))

(defun my-org-clock-kill-entries ()
  "Kill all clock entries at the org node at point.

Assuming they are in the logbook drawer"
  (interactive)
  (let ((end)
        (kill-whole-line t))
    (save-restriction
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (when (re-search-forward "^\\ *:LOGBOOK:\\ *$" nil t)
        (kill-new "")
        (setq end (save-excursion
                    (re-search-forward "^\\ *:END:\\ *$")
                    (point)))
        (while (re-search-forward "^\\ *CLOCK: .*--.*$" end t)
          (beginning-of-line)
          (append-next-kill)
          (kill-line))))))

(defun my-org-element-at-drawer-p ()
  "Returns t if point is at a drawer beginning or end."
  (not (not
        (member (org-element-type (org-element-at-point))
                '(drawer property-drawer)))))

(defun my-org-kill-logbook-entries ()
  "Kill all logbook entries of the org node at point."
  (interactive)
  (let ((beg))
    (save-excursion
      (save-restriction
        (org-narrow-to-subtree)
        (goto-char (point-min))
        (when (and (re-search-forward "^\\ *:LOGBOOK:\\ *$" nil t)
                   (my-org-element-at-drawer-p))
          (beginning-of-line 2)
          (setq beg (point))
          (when (re-search-forward "^\\ *:END:\\ *$" nil t)
            (beginning-of-line)
            (kill-region beg (point))))))))

(defun my-org-logbook-yank ()
  "Yank whatever is in the kill ring into the logbook drawer."
  (interactive)
  (let ((end))
    (save-restriction
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (if (and (re-search-forward "^\\ *:LOGBOOK:\\ *$" nil t)
               (my-org-element-at-drawer-p))
          ;; If there's already a logbook, move to where the clock
          ;; entries should be inserted
          (progn
            (setq end (save-excursion
                        (re-search-forward "^\\ *:END:\\ *$")
                        (beginning-of-line)
                        (point)))
            ;; Insert after active clock (if any)
            (if (re-search-forward "^\\ *CLOCK: .*--.*$" end t)
                (beginning-of-line)
              (goto-char end)))
        (beginning-of-line 2)
        (org-insert-drawer nil "LOGBOOK")
        (delete-char 1))
      (yank))))

(defun my-org-refile-logbook ()
  (interactive)
  (my-org-kill-logbook-entries)
  (save-excursion
    (org-refile '(4))
    (my-org-logbook-yank)))

;;; to remove
(defun my-org-clock-collect-entries (drawer &optional remove)
  "Collect all clock entries from DRAWER.
Remove them from DRAWER if REMOVE is non-nil."
  (cl-assert (eq (org-element-type drawer) 'drawer)
             nil
             "Expected a drawer got %s" (org-element-type drawer))
  (when (string-equal (org-element-property :drawer-name drawer)
                      (or (org-log-into-drawer) "LOGBOOK"))
    (let ((ret
           (cl-loop
            for element in-ref (org-element-contents drawer)
            if (eq (org-element-type element) 'clock)
            collect element
            and if remove do (setf element nil))))
      (org-element-set-contents
       (cl-remove nil (org-element-contents drawer)))
      ret)))

(defun org-element-remove (el)
  "Delete org element EL from its parent."
  (let ((parent (org-element-property :parent el)))
    (org-element-set-contents
     parent
     (cl-remove el (org-element-contents parent)))))

(defun org-element-clock-start<= (c1 c2)
  "Compare two clock elements as returned by `org-element-clock-parser'
and return non-nil if the C1 starts not later than c2."
  (setq c1 (org-element-property :value c1)
	c2 (org-element-property :value c2))
  (cl-loop with val1 with val2
	   for test in '(:year-start :month-start :day-start :hour-start :minute-start)
	   do (setq val1 (org-element-property test c1) val2 (org-element-property test c2))
	   if (< val1 val2)
	   return t
	   if (> val1 val2)
	   return nil
	   finally return t))

(defun org-merge-subtree-clocks (&optional remove)
  "Merge clocks in subtree of headline starting at POINT.
Remove empty logbooks in the sub-tree if REMOVE is non-nil.

Interactively remove empty logbooks when called with prefix-arg \\[universal-argument]."
  (interactive "P")
  (let* (b e
           (headline (org-element-at-point))
           (type (car headline))
           (props (cadr headline)))
    (cl-assert (eq type 'headline)
               nil
               "Expected headline got %s" type)
    (setq b (plist-get props :begin)
          e (plist-get props :end))
    (save-restriction
      (narrow-to-region b e)
      (let* ((data (org-element-parse-buffer))
             (clocks (apply #'append
                            (org-element-map data 'drawer
                              (lambda (el)
                                "Remove all clocks from all drawers and collect them in CLOCKS."
                                (prog1 (org-collect-clock-entries el t)
                                  (when (and remove
					                                   (null (org-element-contents el)))
                                    (org-element-remove el)
                                    )))))))
	(setq clocks (sort clocks #'org-element-clock-start<=))
        (setq headline (org-element-map data 'headline 'identity nil t)) ;; get the first headline within data
        (or (org-element-map
                (org-element-contents headline)
                'drawer ;; check for existing drawer
              (lambda (el)
                "Write all clocks to the first LOGBOOK drawer."
                (when (equal (org-element-property :drawer-name el)
                             (or (org-log-into-drawer) "LOGBOOK"))
                  (org-element-set-contents el clocks)
                  t) ;; indicate that we are done
                )
              nil t 'headline) ;; check only first drawer of current headline
            ;; no drawer yet: add a new one
            (org-element-set-contents
             headline
             (cons (list 'drawer '(:drawer-name "LOGBOOK")
                         clocks)
                   (org-element-contents headline))))
        (kill-region (point-min) (point-max))
        (insert (org-element-interpret-data data))))))

(defun my-org-refile-cache-rebuild ()
  (org-refile-cache-clear)
  (org-refile-get-targets))

(defun my-org-store-agenda-view-A ()
  (interactive)
  (org-store-agenda-views)
  (my-org-agenda-ensure-A))

(defun my-org-agenda-priority-0 ()
  (interactive)
  (org-agenda-priority ?\ ))
(defun my-org-agenda-priority-A ()
  (interactive)
  (org-agenda-priority ?A))
(defun my-org-agenda-priority-B ()
  (interactive)
  (org-agenda-priority ?B))
(defun my-org-agenda-priority-C ()
  (interactive)
  (org-agenda-priority ?C))

(defun my-org-next-block-or-results (arg &optional backward)
  "Jump to the next block or results.

With a prefix argument ARG, jump forward ARG many blocks.

When BACKWARD is non-nil, jump to the previous block.

When BLOCK-REGEXP is non-nil, use this regexp to find blocks.
Match data is set according to this regexp when the function
returns.

Return point at beginning of the opening line of found block.
Throw an error if no block is found."
  (interactive "p")
  (let ((re "^[ \t]*#\\+\\(BEGIN\\|RESULTS:\\)")
	      (case-fold-search t)
	      (search-fn (if backward #'re-search-backward #'re-search-forward))
	      (count (or arg 1))
	      (origin (point))
	      last-element)
    (if backward (beginning-of-line) (end-of-line))
    (while (and (> count 0) (funcall search-fn re nil t))
      (let ((element (save-excursion
		                   (goto-char (match-beginning 0))
		                   (save-match-data (org-element-at-point)))))
	      (when (and (memq (org-element-type element)
			                   '(center-block comment-block dynamic-block
					                              example-block export-block quote-block
					                              special-block src-block verse-block fixed-width))
		               (<= (match-beginning 0)
		                   (org-element-property :post-affiliated element)))
	        (setq last-element element)
	        (cl-decf count))))
    (if (= count 0)
	      (prog1 (goto-char (org-element-property :post-affiliated last-element))
	        (save-match-data (org-show-context)))
      (goto-char origin)
      (user-error "No %s code blocks" (if backward "previous" "further")))))

(defun my-org-previous-block-or-results (arg)
  "Jump to the previous block or results.
With a prefix argument ARG, jump backward ARG many source blocks.
When BLOCK-REGEXP is non-nil, use this regexp to find blocks."
  (interactive "p")
  (my-org-next-block-or-results arg t))

;; override org-next-link to include search in any places, including property
;; drawers.
;; TODO: not working yet
;; https://lists.gnu.org/archive/html/emacs-orgmode/2020-01/msg00186.html
(defun my-org-next-link ()
  (interactive)
  (when (org-in-regexp org-any-link-re)
    (re-search-forward org-any-link-re nil t))
  (re-search-forward org-any-link-re nil t)
  (re-search-backward org-any-link-re nil t)
  (when-let ((link (org-element-lineage (org-element-context) '(link) t)))
    (goto-char (org-element-property :begin link)))
  (when (org-invisible-p) (org-show-context)))

(defun my-org-previous-link ()
  (interactive)
  (re-search-backward org-any-link-re nil t)
  (when-let ((link (org-element-lineage (org-element-context) '(link) t)))
    (goto-char (org-element-property :begin link)))
  (when (org-invisible-p) (org-show-context)))

(defun my-org-attach-edit-attached-image ()
  (interactive)
  (start-process
   "pinta" nil "/usr/bin/pinta"
   (concat (org-attach-dir) "/"
	         (org-element-property :path (org-element-context)))))

(defun my-org-capture-place-template-dont-delete-windows (oldfun args)
  (cl-letf (((symbol-function 'delete-other-windows) 'ignore))
    (apply oldfun args)))

(defvar my-org-attach-copy-attached-targets nil
  "Alist of targets to copy attached to, in the form of (name . path)")
(defvar my-org-attach-copy-attached-doc-exts
  '("epub" "pdf" "mobi"))
(defvar my-org-attach-copy-attached-doc-re
  (format "\\.\\(%s\\)$"
          (string-join
           my-org-attach-copy-attached-doc-exts "\\|")))

(defun my-org-attach-copy-attached-docs ()
  "Copy docs to a mount point.

Use `my-org-attach-copy-attached-targets', which is an list
of (name to-dir staging). Try copying to to-dir.

On failure, hard link to staging.
On success, also move everything from staging to to-dir."
  (interactive)
  (pcase-let* ((name
                (completing-read "Copy attached docs to: "
                                 my-org-attach-copy-attached-targets
                                 nil t))
               (`(,to ,staging) (alist-get name my-org-attach-copy-attached-targets
                                           nil nil #'equal)))
    (let ((basedir (org-attach-dir))
          (failed nil))
      (dolist (attached (org-attach-file-list basedir))
        (when (string-match my-org-attach-copy-attached-doc-re attached)
	        (message "Copying %s to %s (%s)..." attached name to)
          (condition-case nil
	            (copy-file (file-name-concat basedir attached)
		                     (file-name-concat
                          to
			                    (replace-regexp-in-string ":" "_" attached))
                         t)
            (error
             (message "Hardlinking %s to %s staging area (%s)"
                      attached name staging)
             (setq failed t)
             (add-name-to-file
              (file-name-concat basedir attached)
              (file-name-concat
               staging
			         (replace-regexp-in-string ":" "_" attached))
              t)))
	        (message "Done!")))
      (unless failed
        (dolist (staged
                 (directory-files staging nil
                                  my-org-attach-copy-attached-doc-re))
          (message "Moving staged %s to %s (%s)..." staged name to)
          (copy-file (file-name-concat staging staged)
		                 (file-name-concat
                      to
			                (replace-regexp-in-string ":" "_" staged))
                     t)
          (delete-file (file-name-concat staging staged))
          (message "Done!"))))))

(defun my-org-attach-all-url-plaintext (arg)
  (interactive "P")
  (dolist (url (my-org-http-s-links-in-entry))
    (my-org-attach-url-plaintext url)))

(defun my-org-attach-url-plaintext (url)
  (interactive (list (completing-read "Url to fetch: " (my-org-http-s-links-in-entry))))
  (my-org-attach-url-plaintext-internal url current-prefix-arg t))

(defun my-org-attach-url-plaintext-all-media (url)
  (interactive (list (completing-read "Url to fetch: "
                                      (my-org-http-s-links-in-entry))))
  (my-org-attach-url-plaintext-internal url current-prefix-arg t t))

(defun my-org-attach-url (url)
  (interactive (list (completing-read "Url to fetch: "
                                      (my-org-http-s-links-in-entry))))
  (let* ((url (my-rewrite-url url))
         (filename (expand-file-name (my-make-filename-from-url url)
                                     (org-attach-dir t))))
    (my-wget-async url filename current-prefix-arg)))

(defun my-org-attach-url-plaintext-internal (url &optional no-tor move-if-large save-all-media)
  (let* ((lynx-buffer (format "*lynx %s*" url))
         (url (url-rw url))
         (filename (expand-file-name (my-make-filename-from-url url)
                                     (org-attach-dir t)))
         (coding-system-for-write 'utf-8))
    (ignore-errors (kill-buffer lynx-buffer))
    (my-touch-new-file filename)
    (org-attach-sync)
    (set-process-sentinel
     (my-start-process-with-torsocks
      current-prefix-arg
      "org-lynx" lynx-buffer "lynx" "-dump" "--display_charset" "utf-8" url)
     (lambda (process event)
       (with-current-buffer (process-buffer process)
         (goto-char (point-min))
         (write-file filename)
         (message "Lynx dumped to: %s" filename)
         (when save-all-media
           (when-let ((urls (http-s-media-links-in-buffer)))
             (message "Downloading %d media files..." (length urls))
             (wget-async-urls-with-prefix
              urls (concat filename "-") no-tor move-if-large))))))))

;; node creation; start of grok
;; FIXME: decouple clients from org
(defun my-org-create-node (info &optional attach)
  (cond ((alist-get "Authors" info nil nil 'string=)
	       (my-org-create-book-node info attach))
	      ((alist-get "Director" info nil nil 'string=)
	       (my-org-create-video-node info attach))
	      ((and (alist-get "Developers" info nil nil 'string=)
              (string-match "\\<game\\>"
                            (alist-get "Description" info nil nil 'string=)))
	       (my-org-create-video-game-node info attach))
        ((alist-get "Developers" info nil nil 'string=)
         (my-org-create-software-node info attach))
	      ((alist-get "Designers" info nil nil 'string=)
	       (my-org-create-game-node info attach))
	      ((alist-get "Founded" info nil nil 'string=)
         (my-org-create-organisation-node info attach))
        ((alist-get "Latitude" info nil nil 'string=)
	       (my-org-create-location-node info attach))
        ((alist-get "Born" info nil nil 'string=)
         (my-org-create-people-node info attach))
	      (t (my-org-create-entity-node info attach))))

(defun my-org-attach-and-add-properties-to-node (info attach)
  (when (and attach (alist-get "Cover" info nil nil 'string=))
    (ignore-error 'file-already-exists
      (org-attach-url (alist-get "Cover" info nil nil 'string=)))
    (setq info (assoc-delete-all "Cover" info 'string=)))
  (dolist (pair info)
    (when (and (cdr pair) (string> (cdr pair) ""))
      (org-entry-put (point)
		                 (decode-coding-string (car pair) 'utf-8)
		                 (decode-coding-string (cdr pair) 'utf-8))))
  (org-entry-put (point) "CREATED"
                 (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time)))
  (org-attach-sync)
  (when (buffer-narrowed-p)
    (goto-char (point-min))))

(defun my-org-create-book-node (book-info attach)
  (org-capture nil "book")
  (insert (format
	         "%s - %s - %s"
	         (or (alist-get "Authors" book-info "" nil 'string=) "")
	         (alist-get "Title" book-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" book-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node book-info attach))
(defun my-org-create-video-node (video-info attach)
  (org-capture nil "video")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Director" video-info "" nil 'string=)
	         (alist-get "Title" video-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" video-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node video-info attach))
(defun my-org-create-location-node (book-info attach)
  (org-capture nil "location")
  (insert (format
	         "%s"
	         (alist-get "Title" book-info "" nil 'string=)))
  (my-org-attach-and-add-properties-to-node book-info attach))
(defun my-org-create-game-node (game-info attach)
  (org-capture nil "game")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Designers" game-info "" nil 'string=)
	         (alist-get "Title" game-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" game-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node game-info attach))
(defun my-org-create-video-game-node (game-info attach)
  (org-capture nil "videogame")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Developers" game-info "" nil 'string=)
	         (alist-get "Title" game-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" game-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node game-info attach))
(defun my-org-create-software-node (software-info attach)
  (org-capture nil "software")
  (insert (format
	         "%s - %s"
           (alist-get "Title" software-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" software-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node software-info attach))
(defun my-org-create-organisation-node (organisation-info attach)
  (org-capture nil "organisation")
  (insert (format
	         "%s - %s"
           (alist-get "Title" organisation-info "" nil 'string=)
           (my-extract-year
            (alist-get "Founded" organisation-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node organisation-info attach))
(defun my-org-create-people-node (people-info attach)
  (org-capture nil "people")
  (insert (format
	         "%s - %s-%s"
           (alist-get "Title" people-info "" nil 'string=)
           (my-extract-year (alist-get "Born" people-info "" nil 'string=))
           (my-extract-year (alist-get "Died" people-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node people-info attach))
(defun my-org-create-pacman-software-node (package)
  (interactive "sPacman package name: ")
  (my-org-create-software-node (my-grok-pacman package) nil))
(defun my-org-create-entity-node (entity-info attach)
  (org-capture nil "entity")
  (insert (format
	         "%s"
	         (alist-get "Title" entity-info "" nil 'string=)))
  (my-org-attach-and-add-properties-to-node entity-info attach))
(defun my-org-create-audio-node (audio-info attach)
  (org-capture nil "ya")
  (insert (format
	         "%s - %s - %s"
	         (or (alist-get "Authors" audio-info "" nil 'string=) "")
	         (alist-get "Title" audio-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" audio-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node audio-info attach))

;; TODO: these requires are unnecessary for more essential functionalities of
;; org customisation. Find a way to delay them
(require 'my-wikipedia)
(require 'my-github)
(require 'my-gitlab)
(require 'my-pacman)
(require 'my-openlibrary)
(require 'my-codeberg)
(defun my-grok-dispatcher (url)
  (when-let ((host (url-host (url-generic-parse-url url))))
    (cond ((string-match "wikipedia\\.org" host) 'my-grok-wikipedia)
          ((string-match "github\\.com" host) 'my-grok-github)
          ((string-match "codeberg\\.org" host) 'my-grok-codeberg)
          ((string-match "\\(gitlab\\.\\|salsa.debian.org\\)" host)
           'my-grok-gitlab)
          ((string-match "openlibrary.org" host) 'my-grok-openlibrary)
          (t nil))))
(defun my-grok-update-properties ()
  (interactive)
  (when-let* ((url (org-entry-get (point) "Source"))
              (source-dispatcher (my-grok-dispatcher url)))
    (my-org-attach-and-add-properties-to-node
     (funcall source-dispatcher url) t))
  (when-let ((isbn (org-entry-get (point) "ISBN")))
    (my-org-attach-and-add-properties-to-node (my-grok-openlibrary-isbn isbn) t))
  (when-let ((url (org-entry-get (point) "OpenLibrary-link")))
    (my-org-attach-and-add-properties-to-node (my-grok-openlibrary url) t))
  (when-let ((package (org-entry-get (point) "Pacman-package-name")))
    (my-org-attach-and-add-properties-to-node (my-grok-pacman package) nil))
  (when-let ((url (org-entry-get (point) "Wikipedia-link")))
    (my-org-attach-and-add-properties-to-node (my-grok-wikipedia url) t)))
(defun my-org-protocol-grok (data)
  (when-let ((url (plist-get data :url)))
    (my-org-grok url))
  nil)

(defun my-org-grok (url)
  (when-let* ((grok-fun (my-grok-dispatcher url))
              (info (funcall grok-fun url)))
    (my-org-create-node info t)))

(defun my-eww-org-protocol-grok ()
  "grok from eww"
  (interactive)
  (org-protocol-grok
   (list :url (plist-get eww-data :url))))

;; org capture rss
(defun my-org-rss-xml-create-audio-node (url)
  (interactive (list (read-string "Feed URL: "
				                          (thing-at-point-url-at-point))))
  (my-org-rss-xml-create-node url 'my-org-create-audio-node))
(defun my-org-rss-xml-create-book-node (url)
  (interactive (list (read-string "Feed URL: "
				                          (thing-at-point-url-at-point))))
  (my-org-rss-xml-create-node url 'my-org-create-book-node))
(defun my-org-rss-xml-create-node (url create-node-fun)
  (let* ((xml
	        (with-current-buffer (url-retrieve-synchronously url)
	          (my-skip-http-header)
	          (car (xml-parse-region (point) (point-max)))))
	       (channel (my-xml-get-first-child xml 'channel))
	       )
    (funcall create-node-fun
	           (list
	            (cons "Feed-url" url)
	            (cons "Title" (decode-coding-string
                             (my-xml-get-first-child-text channel 'title) 'utf-8))
	            (cons "Description"
		                (decode-coding-string
                     (my-xml-get-first-child-text channel 'description) 'utf-8))
	            (cons "Website" (my-xml-get-first-child-text channel 'link))
	            (cons "Cover"
		                (or (my-xml-get-first-child-text
			                   (my-xml-get-first-child channel 'image) 'url)
			                  (dom-attr
			                   (my-xml-get-first-child channel 'itunes:image) 'href)))
	            (cons "Authors" (my-xml-get-first-child-text
                               channel 'itunes:author)))
	           t)))

(require 'my-algo)
(defun my-radix-org-from-tree (tree)
  (let ((radix-tree-type 'vector))
    (radix-tree-iter-subtrees
     tree
     (my-radix-org-iter-n 1 []))))

(defun my-radix-org-iter-n (depth prefix)
  (lambda (p s)
    (let ((nprefix (seq-concatenate radix-tree-type prefix p)))
      (insert (make-string depth ?*) " ")
      (pcase s
        ((radix-tree-leaf v) (insert "[[" (string-join nprefix "/") "][" (string-join p "/") "]]" "\n"))
        (_
         (insert (string-join p "/") "\n")
         (radix-tree-iter-subtrees s (my-radix-org-iter-n (1+ depth) nprefix)))))))

(defun my-radix-org ()
  (interactive)
  (let* ((file-name (buffer-file-name))
         (buffer-name (file-name-with-extension
                       (file-name-base file-name)
                       "org"))
         (save-file-name (file-name-with-extension file-name "org"))
         (tree (let ((max-lisp-eval-depth 32000))
                 (save-excursion (my-radix-tree-from-list)))))
    (with-current-buffer (get-buffer-create buffer-name)
      (org-mode)
      (erase-buffer)
      (my-radix-org-from-tree tree)
      (goto-char (point-min)))
    (switch-to-buffer buffer-name)))

;;; format org mode elements
(defun my-org-format-link (url text)
  (format "[[%s][%s]]" url text))

(defun my-org-format-heading (text level)
  (format "%s %s"
          (make-string level ?*) text))

(defun my-org-update-updated ()
  (interactive)
  (when (and (derived-mode-p 'org-mode)
             (not (org-before-first-heading-p)))
    (org-entry-put
     (point) "UPDATED"
     (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time)))))

;;; override org-recoll-format-results
(defun my-org-recoll-format-results ()
  (require 'org-recoll)
  "Format recoll results in buffer."
  ;; Format results in org format and tidy up
  (org-recoll-regexp-replace-in-buffer
   "^.*?\\[\\(.*?\\)\\]\\s-*\\[\\(.*?\\)\\]\\(.*\\)$"
   "* [[\\1][\\2]] <\\1>\\3")
  (org-recoll-regexp-replace-in-buffer
   (format "<file://.*?%s\\(.*/\\).*>" (substring my-docs-root-dir 1))
   "(\\1)")
  (org-recoll-regexp-replace-in-buffer "\\/ABSTRACT" "")
  (org-recoll-regexp-replace-in-buffer "ABSTRACT" "")
  ;; Justify results
  (goto-char (point-min))
  (org-recoll-fill-region-paragraphs)
  ;; Add emphasis
  (highlight-phrase (org-recoll-reformat-for-file-search
                     org-recoll-search-query)
                    'bold-italic))

(defun my-org-recoll-mdn (query)
  (interactive "sSearch mdn: ")
  (org-recoll-search (format "%s dir:mdn" query)))

(defun my-org-recoll-python (query)
  (interactive "sSearch python: ")
  (org-recoll-search (format "%s dir:python-3.9.7-docs-html" query)))

(defun my-org-recoll-php (query)
  (interactive "sSearch php: ")
  (org-recoll-search (format "%s dir:php-chunked-xhtml" query)))

(defun my-org-recoll-yesod (query)
  (interactive "sSearch yesod: ")
  (org-recoll-search (format "%s dir:yesod-cookbook OR dir:yesodweb.com" query)))

(defun my-org-entry-at-point-to-tsv (id)
  (string-join
   (cons (number-to-string id)
         (mapcar
          (lambda (key) (org-entry-get (point) key))
          (list "ITEM" "Referral" "Wikipedia-link" "IMDB-link")))
   "\t"))

(defun my-org-swap-referral-with-headline ()
  "Swap Referral property with headline of org node at point.

Remove the Referral property if empty."
  (interactive)
  (let ((ref (or (org-entry-get (point) "Referral") ""))
        (headline (org-entry-get (point) "ITEM")))
    (if (string-empty-p headline)
        (org-delete-property "Referral")
      (org-entry-put (point) "Referral" headline))
    (org-edit-headline ref)))

(defun my-org-clean-up-entry ()
  "Clean up an org entry.

Delete empty standard properties.
Sync attachment.
Remove trailing whitespaces.
Flush lines with only some common symbols."
  (interactive)
  (my-org-delete-empty-properties)
  (org-attach-sync)
  (save-excursion
    (save-restriction
      (org-narrow-to-subtree)
      (flush-lines "^\\ *[-]+\\ *$")
      (delete-trailing-whitespace)
      (goto-char (point-max))
      (when (<= (skip-chars-backward "\n") -2)
        (delete-region (1+ (point)) (point-max))))))

(defun my-org-delete-empty-properties ()
  "Delete empty (standard) properties at point."
  (interactive)
  (pcase-dolist (`(,name . ,value) (org-entry-properties (point) 'standard))
    (when (string-empty-p value) (org-entry-delete (point) name))))

(defvar org-entries-tsv-buffer "*org-entries-tsv*")
(defun my-org-entries-at-point-to-tsv (beg end)
  (interactive "r")
  (with-current-buffer (get-buffer-create org-entries-tsv-buffer)
    (erase-buffer))
  (let ((row) (id 0))
    (save-excursion
      (goto-char beg)
      (while (< (point) end)
        (when (equal (org-entry-get (point) "TODO") "TODO")
          (setq row (my-org-entry-at-point-to-tsv id))
          (with-current-buffer org-entries-tsv-buffer
            (insert row "\n"))
          (setq id (1+ id)))
        (org-next-visible-heading 1))))
  (switch-to-buffer-other-window org-entries-tsv-buffer))

(defun my-org-entries-attach-plaintext-all-media (beg end)
  (interactive "r")
  (save-excursion
    (goto-char beg)
    (while (< (point) end)
      (my-org-attach-url-plaintext-all-media (car (my-org-http-s-links-in-entry)))
      (org-next-visible-heading 1))))

(defvar my-org-doc-dir nil "Directory to docs written in org.")
(defun my-org-open-org-doc (filename)
  (interactive
   (list
    (completing-read
     "Open org doc: "
     (mapcar (lambda (name) (substring name (length my-org-doc-dir)))
             (directory-files-recursively my-org-doc-dir "\\.org$")))))
  (find-file (concat my-org-doc-dir filename)))

(defun my-org-open-org-file (filename)
  (interactive
   (list
    (completing-read
     "Open org file: "
     (directory-files org-directory nil "\\.org$"))))
  (find-file (file-name-concat org-directory filename)))

(defun my-org-agenda-after-show () (beginning-of-line 1))

(defun my-org-agenda-ensure-A ()
  (org-agenda nil "A")
  (unless (get-text-property (point) 'org-series-redo-cmd)
    (kill-buffer)
    (org-agenda nil "A")))

(defun my-org-agenda-redo-all ()
  (interactive)
  (message "time now is %s"
           (format-time-string "%Y-%m-%d %a %H:%M:%S" (current-time)))
  (my-org-agenda-ensure-A)
  (dolist (buffer (buffer-list))
    (with-current-buffer buffer
      (when (derived-mode-p 'org-agenda-mode)
        (print buffer)
        (org-agenda-redo t)))))

(defun my-org-copy-dwim ()
  (interactive)
  (cond ((org-in-src-block-p)
	       (my-org-copy-src-block-at-point))
        ((my-org-in-or-at-block-p) (my-org-copy-block-at-point))
        (t (org-refile-copy))))

;; to override `org--mouse-open-at-point' - we don't want
;; `org-open-at-point' to toggle a checkbox when point is at the
;; beginning of a link
(defun my-org--mouse-open-at-point (orig-fun &rest args)
  (let ((context (org-context)))
    (cond
     ((assq :headline-stars context) (org-cycle))
     ((assq :item-bullet context)
      (let ((org-cycle-include-plain-lists t)) (org-cycle)))
     ((org-footnote-at-reference-p) nil)
     (t (apply orig-fun args)))))

(defun my-org-vote-up (&optional points)
  (interactive "p")
  (org-entry-put
   (point)
   "Vote"
   (number-to-string
    (+ (or points 1)
       (string-to-number
        (or (org-entry-get (point) "Vote") "0"))))))

(defun my-org-vote-down (&optional points)
  (interactive "p")
  (my-org-vote-up (- points)))

;; used to add an :after advice to `org-insert-structure-template'.
(require 'my-buffer)
(defun my-org-edit-special (type)
  "Choose mode if src block. Then enter edit special

With a prefix arg, yank and exit immediately."
  (when (equal type "src")
    (insert (string-remove-suffix
             "-mode" (prin1-to-string (my-read-major-mode)))))
  (let ((mark-was-active mark-active))
    (org-edit-special)
    (when current-prefix-arg
      (unless mark-was-active
        (yank))
      (org-edit-src-exit))))

;; used to add an :after advice to `org-edit-special'.
(defun my-org-edit-special-after ()
  ;; some modes (e.g. diff mode) are read-only by default, which
  ;; does not make sense when the intention is to edit
  (read-only-mode 0))

(defun my-link-to-line-number-in-prog-mode ()
  "When in prog-mode, use line number as search item."
  (when (derived-mode-p 'prog-mode)
    (number-to-string (org-current-line))))

;; override `org-capture-set-plist'
(defun my-org-capture-set-plist (entry)
  "Initialize the property list for ENTRY from the template definition."
  (setq org-capture-plist (copy-sequence (nthcdr 5 entry)))
  (org-capture-put :key (car entry) :description (nth 1 entry)
		               :target (nth 3 entry))
  (let ((txt (nth 4 entry)) (type (or (nth 2 entry) 'entry)))
    (when (or (not txt) (and (stringp txt) (not (string-match "\\S-" txt))))
      ;; The template may be empty or omitted for special types.
      ;; Here we insert the default templates for such cases.
      (cond
       ((eq type 'item) (setq txt "- %?"))
       ((eq type 'checkitem) (setq txt "- [ ] %?"))
       ((eq type 'table-line) (setq txt "| %? |"))
       ;; >>> the overriding difference
       ((member type '(nil entry)) (setq txt "* %?"))))
    (org-capture-put :template txt :type type)))

(defun my-org-entry-sizes ()
  "Size analysis of all entries in the current org buffer.

A new org buffer appears, with the whole org tree of the original
buffer preserved, annotated with the size"
  (with-current-buffer (get-buffer-create "*org-sizes*")
    (erase-buffer)
    (org-mode))
  (save-excursion
    (save-restriction
      (org-content)
      (beginning-of-buffer)
      (unless (org-at-heading-p)
        (org-next-visible-heading 1))
      (let ((beg) (line))
        (while (org-at-heading-p)
          (setq beg (point)
                line (buffer-substring-no-properties
                      beg (save-excursion (org-end-of-line) (point))))
          (org-next-visible-heading 1)
          (setq line (format "%s (%d)" line (- (point) beg)))
          (with-current-buffer "*org-sizes*"
            (insert line "\n"))))))
  (switch-to-buffer-other-window "*org-sizes*"))

(defun my-org-capture-todo ()
  "Capture todo template."
  (interactive)
  (org-capture nil "t")
  (org-capture-finalize)
  (message "todo captured."))

;; for `org-link-frame-setup'
(defun my-org-gnus-other-window-advice ()
  (other-window 1))


;; override `org-id-store-link' with a priority property
(defun my-org-id-store-link ()
  "Store a link to the current entry, using its ID.

If before first heading store first title-keyword as description
or filename if no title."
  (interactive)
  (when (and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode))
    (let* ((link (concat "id:" (org-id-get-create)))
	         (case-fold-search nil)
	         (desc (save-excursion
		               (org-back-to-heading-or-point-min t)
                   (cond ((org-before-first-heading-p)
                          (let ((keywords (org-collect-keywords '("TITLE"))))
                            (if keywords
                                (cadr (assoc "TITLE" keywords))
                              (file-name-nondirectory
			                         (buffer-file-name (buffer-base-buffer))))))
		                     ((looking-at org-complex-heading-regexp)
			                    (if (match-end 4)
			                        (match-string 4)
			                      (match-string 0)))
                         (t link))))
           (prio (org-entry-get (point) "PRIORITY")))
      (org-link-store-props :link link :description desc :type "id"
                            :priority prio)
      link)))

;;; task management
(defcustom my-org-task-categories nil
  "Task categories for org task id creation.

Task ID will be in the format of <category>-<counter>. For
example, if `my-org-task-categories' is '(WORK CHORE), task ids
will be in the format of WORK-42 CHORE-1024 etc."
  :group 'my-org
  :type '(repeat symbol))

(defcustom my-org-task-next-id-file (locate-user-emacs-file "org-task-ids")
  "Files to store the next id of each task category."
  :group 'my-org
  :type 'file)

(defcustom my-org-task-property-name "TASK_ID"
  "The property field name for task ids."
  :group 'my-org
  :type 'string)

(defun my-org-task-init ()
  "Initialise next ids to be 0 and write them to `my-org-task-next-id-file'."
  (my-org-task-write-next-ids
   (mapcar
    (lambda (cat)
      `(,cat . 0))
    my-org-task-categories)))

(defun my-org-task-read-next-ids ()
  "Read next ids from `my-org-task-next-id-file'."
  (when (file-exists-p my-org-task-next-id-file)
    (with-temp-buffer
      (insert-file-contents my-org-task-next-id-file)
      (goto-char (point-min))
      (read (current-buffer)))))

(defun my-org-task-write-next-ids (next-ids)
  "Write NEXT-IDS to `my-org-task-next-id-file'."
  (with-temp-buffer
    (insert (prin1-to-string next-ids))
    (write-region nil nil my-org-task-next-id-file)))

(defun my-org-task-increment-id (category)
  "Increment the next id of CATEGORY.

Return the next id before incrementing."
  (let* ((next-ids (my-org-task-read-next-ids))
         (next-id (alist-get category next-ids)))
    (setf (alist-get category next-ids)
          (1+ next-id))
    (my-org-task-write-next-ids next-ids)
    next-id))

(defun my-org-task-remove-id ()
  "Remove id from task at point."
  (interactive)
  (let* ((headline (org-entry-get (point) "ITEM"))
         (old-id (org-entry-get (point) my-org-task-property-name))
         (new-headline (replace-regexp-in-string
                        (format "^%s" (if old-id (format "%s " old-id) ""))
                        ""
                        headline)))
    (org-entry-delete (point) my-org-task-property-name)
    (org-edit-headline new-headline)))

(defun my-org-task-add-id (category)
  "Add id of CATEGORY to task at point."
  (interactive (list (intern (completing-read
                              "Category: "
                              (mapcar
                               (lambda (cat) (format "%s" cat))
                               my-org-task-categories)))))
  (my-org-task-remove-id)
  (let* ((id (format "%s%s%d"
                     category
                     my-org-task-id-separator
                     (my-org-task-increment-id category)))
         (headline (org-entry-get (point) "ITEM"))
         (new-headline (format "%s %s" id headline)))
    (org-entry-put (point) my-org-task-property-name id)
    (org-edit-headline new-headline)))

(defcustom my-org-task-relations
  '(("BLOCKS" . "BLOCKED_BY")
    ("CAUSES" . "CAUSED_BY")
    ("DUPLICATES" . "DUPLICATED_BY")
    ("RELATED" . "RELATED")
    ("BLOCKED_BY" . "BLOCKS")
    ("CAUSED_BY" . "CAUSES")
    ("DUPLICATED_BY" . "DUPLICATES"))
  "Task relations and their dual relations.

Better be symmetric, i.e. if (A . B) is an element, so should (B
. A)."
  :group 'my-org
  :type '(repeat (cons string string)))

(defcustom my-org-task-id-separator "~"
  "Separator in task id, separating task category from number."
  :group 'my-org
  :type 'string)

(defcustom my-org-properties-separator ", "
  "Separator in a property value field."
  :group 'my-org
  :type 'string)

(defun my-org-entry-add (pom property value)
  "Add VALUE to the values in PROPERTY at POM.

The values are separated by `my-org-properties-separator'.
See also `org-entry-add-to-multivalued-property'."
  (let ((old (org-entry-get pom property)))
    (if old
        (org-entry-put
         pom property
         (format "%s%s%s" old my-org-properties-separator value))
      (org-entry-put pom property value))))

(defun my-org-entry-remove (pom property value)
  "Remove VALUE from the values in PROPERTY at POM.

The values are separated by `my-org-properties-separator'.
See also `org-entry-remove-from-multivalued-property'."
  (let* ((old (org-entry-get pom property))
         (new (replace-regexp-in-string
               ;; Remove value when it is the only one in the property
               (regexp-quote value)
               ""
               (replace-regexp-in-string
                ;; Remove the non-first occurrence of the value
                (regexp-quote (format "%s%s" my-org-properties-separator value))
                ""
                (replace-regexp-in-string
                 ;; Remove the non-last occurrence of the value
                 (regexp-quote (format "%s%s" value my-org-properties-separator))
                 ""
                 old)))))
    (if (string-empty-p new)
        (org-entry-delete pom property)
      (org-entry-put pom property new))))

(defun my-org-task-associate-internal (relation)
  "Add the last stored link as RELATION to the task at point."
  (when-let ((link (pop org-stored-links)))
    (my-org-entry-add (point) relation
                      (format "[[%s][%s]]" (car link) (cadr link)))))

(defun my-org-task-dissociate-internal (relation)
  "Remove the last stored link as RELATION from the task at point."
  (when-let ((link (pop org-stored-links)))
    (my-org-entry-remove (point) relation
                         (format "[[%s][%s]]" (car link) (cadr link)))))

(defun my-org-task-associate ()
  "Associate the task at point with another task.

Use `org-goto' to choose the task to associate with. Adds the
dual relation link-back on that task."
  (interactive)
  (let* ((relation
          (completing-read "Relation: "
                           (mapcar 'car my-org-task-relations) nil t))
         (dual (alist-get relation my-org-task-relations nil nil 'equal)))
    (call-interactively 'org-store-link)
    (save-excursion
      (call-interactively 'org-goto)
      (my-org-task-associate-internal dual)
      (call-interactively 'org-store-link))
    (my-org-task-associate-internal relation)))

;; TODO: Choose from associated tasks rather than all possible
;; headlines.
(defun my-org-task-dissociate ()
  "Dissociate the task at point with another task.

Use `org-goto' to choose the task to dissociate from. Removes the
dual relation link-back on that task."
  (interactive)
  (let* ((properties (org-entry-properties))
         (relation
          (completing-read "Relation: "
                           (mapcar 'car my-org-task-relations)
                           (lambda (prop) (alist-get prop properties nil nil 'equal))
                           t))
         (dual (alist-get relation my-org-task-relations nil nil 'equal)))
    (call-interactively 'org-store-link)
    (save-excursion
      (call-interactively 'org-goto)
      (my-org-task-dissociate-internal dual)
      (call-interactively 'org-store-link))
    (my-org-task-dissociate-internal relation)))

;; to override `org-entry-blocked-p'.
(defun my-org-entry-blocked-p ()
  "Non-nil if entry at point is blocked."
  (and (org-entry-get (point) "BLOCKED_BY")
       (member (org-entry-get nil "TODO") org-not-done-keywords)))

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