path: root/emacs/.emacs.d/lisp/my/my-org.el

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

;; 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-open-default-notes-file ()
  (interactive)
  (find-file org-default-notes-file))

;; 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)))
        (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-clock-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 (re-search-forward "^\\ *:LOGBOOK:\\ *$" nil t)
          ;; 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-clock-refile-clocking ()
  (interactive)
  (my-org-clock-kill-entries)
  (save-excursion
    (call-interactively 'org-goto)
    (my-org-clock-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 ()
  (interactive)
  (let* ((name
          (completing-read "Copy attached docs to: "
                           my-org-attach-copy-attached-targets))
         (path (alist-get name my-org-attach-copy-attached-targets
                          nil nil #'equal)))
    (let ((basedir (org-attach-dir)))
      (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 path)
	        (copy-file (file-name-concat basedir attached)
		                 (file-name-concat
                      path
			                (replace-regexp-in-string ":" "_" attached)))
	        (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 (my-rewrite-url 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)
(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 "\\(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"))

(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 advice to `org-insert-structure-template'.
(require 'my-buffer)
(defun my-org-edit-special (type)
  (when (equal type "src")
    (insert (string-remove-suffix
             "-mode" (prin1-to-string (my-read-major-mode)))))
  (org-edit-special))

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

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