;;; ol-todo.el --- Store symbolic link to a TODO entry  -*- lexical-binding: t -*-

;; Copyright (C) 2014-2022 Free Software Foundation, Inc.

;; Author: Tyler Grinn <tylergrinn@gmail.com>
;; Package-Requires: ((emacs "27.2"))
;; Version: 0.0.1

;;; Commentary:

;; When this type of link is inserted, the todo keyword of the target
;; heading is displayed before the link.  With point inside a todo
;; link, use C-c C-c to update the link and C-c C-t to change the todo
;; status of the target heading.
;;
;; Use `org-todo-link-store' to store the heading at point in
;; `org-stored-links'.  This is not registered as a provider for
;; `org-store-link' because it would override the default storing
;; behavior for org files.

;;; Code:

;;;; Requirements:

(require 'org)
(require 'ol)
(require 'org-keys)
(require 'org-refile)
(require 'org-element)

;;;; Org todo link keymap

(defun org-todo-link-recalculate ()
  "Recalculate TODO status for todo link at point."
  (interactive)
  (if-let* ((ov (seq-find
                 (lambda (o) (overlay-get o 'ol-todo))
                 (overlays-at (point))))
            (start (car (org-in-regexp org-link-any-re)))
            (link (save-excursion
                    (goto-char start)
                    (org-element-link-parser)))
            (path (org-element-property :path link)))
      (overlay-put ov 'before-string (org-todo-link-get-todo path))))

(defun org-todo-link-todo ()
  "Set TODO keyword on todo link at point."
  (interactive)
  (when-let* ((ov (seq-find
                   (lambda (o) (overlay-get o 'ol-todo))
                   (overlays-at (point))))
              (start (car (org-in-regexp org-link-any-re)))
              (link (save-excursion
                      (goto-char start)
                      (org-element-link-parser)))
              (path (org-element-property :path link)))
    (save-window-excursion
      (let* ((org-link-frame-setup '((file . find-file)))
             (pos (org-todo-link-find path)))
        (save-excursion
          (goto-char pos)
          (org-todo))))
    (overlay-put ov 'before-string (org-todo-link-get-todo path))))

(defvar org-todo-link-keymap
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map org-mouse-map)
    (mapc
     (lambda (k) (define-key map (kbd (car k)) (cdr k)))
     '(("C-c C-c" . org-todo-link-recalculate)
       ("C-c C-t" . org-todo-link-todo)))
    map)
  "Keymap for todo links.")

;; Create `todo' style link
;;;###autoload
(org-link-set-parameters "todo"
                         :complete #'org-todo-link-complete
                         :insert-description #'org-todo-link-description
                         :activate-func #'org-todo-link-activate
                         :face #'org-todo-link-face
                         :follow #'org-todo-link-follow
                         :keymap org-todo-link-keymap)

(defun org-todo-link-complete (&optional _)
  "Prompt user to complete path to TODO item in refile targets."
  (let ((it (org-refile-get-location "TODO Item: "))
        (org-link-frame-setup '((file . find-file)))
        org-stored-links)
    (save-window-excursion
      (org-open-file (nth 1 it))
      (save-excursion
        (goto-char (nth 3 it))
        (org-todo-link-store)))
    (caar org-stored-links)))

(defun org-todo-link-description (loc _)
  "Generate probable description from todo link LOC."
  (save-window-excursion
    (let* ((org-link-frame-setup '((file . find-file)))
           (pos (org-todo-link-find
                 (replace-regexp-in-string "^todo:" "" loc))))
      (org-entry-get pos "ITEM"))))

(defun org-todo-link-activate (start end path &rest _)
  "Create overlay from START to END and display todo of heading at PATH."
  (let ((overlays (seq-filter
                   (lambda (o) (overlay-get o 'ol-todo))
                   (overlays-in start end))))
    (if (not overlays)
        (let ((ov (make-overlay start end)))
          (overlay-put ov 'ol-todo t)
          (overlay-put ov 'evaporate t)
          (overlay-put ov 'before-string (org-todo-link-get-todo path)))
      (move-overlay (car overlays) start end)
      (overlay-put (car overlays) 'before-string (org-todo-link-get-todo path))
      (mapc #'delete-overlay (cdr overlays)))))

(defun org-todo-link-face (path)
  "Calculate TODO status for link at point with PATH."
  (if-let ((ov (seq-find
                (lambda (o) (overlay-get o 'ol-todo))
                (overlays-at (1- (point))))))
      (overlay-put ov 'before-string (org-todo-link-get-todo path)))
  'org-link)

(defun org-todo-link-follow (path _)
  "Open a todo link to PATH."
  (goto-char (org-todo-link-find path)))

;;;; Commands

;;;###autoload
(defun org-todo-link-store ()
  "Store a todo link to the current heading."
  (interactive)
  (when (and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode))
    (let (link)
      (let (org-stored-links)
        (org-store-link '(16) t)
        (setq link (car org-stored-links)))
      (when link
        (setcar link (replace-regexp-in-string "^file:" "todo:" (car link)))
        (push link org-stored-links)))))

;;;; Utility Expressions

(defun org-todo-link-find (path)
  "Jump to file part of PATH and return the heading position."
  (let ((link (with-temp-buffer
                (insert "[[file:" path "]]")
                (goto-char (point-min))
                (org-element-link-parser)))
        (org-link-search-must-match-exact-headline t))
    (org-open-file (org-element-property :path link))
    (org-with-wide-buffer
     (org-link-search (org-element-property :search-option link))
     (point))))

(defun org-todo-link-get-todo (path)
  "Get TODO keyword at PATH."
  (save-window-excursion
    (let* (broken
           (org-link-frame-setup '((file . find-file)))
           (todo (condition-case err
                    (org-entry-get (org-todo-link-find path) "TODO")
                   (error
                    (message (error-message-string err))
                    (setq broken t)))))
      (concat "<"
              (cond
               (broken "BROKEN")
               (todo 
                (propertize todo 'face (if (member todo org-done-keywords)
                                           'org-done
                                         'org-todo)))
               (t "NONE"))
              "> "))))

(provide 'ol-todo)

;;; ol-todo.el ends here