;;; lang/org/autoload/org-link.el -*- lexical-binding: t; -*-

(defun +org--relative-path (path root)
  (if (and buffer-file-name (file-in-directory-p buffer-file-name root))
      (file-relative-name path)
    path))

(defun +org--read-link-path (key dir &optional fn)
  (let ((file (funcall (or fn #'read-file-name) (format "%s: " (capitalize key)) dir)))
    (format "%s:%s" key (file-relative-name file dir))))

;;;###autoload
(defun +org-define-basic-link (key dir-var &rest plist)
  "Define a link with some basic completion & fontification.

KEY is the name of the link type. DIR-VAR is the directory variable to resolve
links relative to. PLIST is passed to `org-link-set-parameters' verbatim.

Links defined with this will be rendered in the `error' face if the file doesn't
exist, and `org-link' otherwise."
  (declare (indent 2))
  (let ((requires (plist-get plist :requires))
        (dir-fn (if (functionp dir-var)
                    dir-var
                  (lambda () (symbol-value dir-var)))))
    (apply #'org-link-set-parameters
           key
           :complete (lambda ()
                       (if requires (mapc #'require (ensure-list requires)))
                       (+org--relative-path (+org--read-link-path key (funcall dir-fn))
                                            (funcall dir-fn)))
           :follow   (lambda (link)
                       (org-link-open-as-file (expand-file-name link (funcall dir-fn)) nil))
           :face     (lambda (link)
                       (let* ((path (expand-file-name link (funcall dir-fn)))
                              (option-index (string-match-p "::\\(.*\\)\\'" path))
                              (file-name (substring path 0 option-index)))
                         (if (file-exists-p file-name)
                             'org-link
                           'error)))
           (plist-put plist :requires nil))))

;;;###autoload
(defun +org-link-read-desc-at-point (&optional default context)
  "TODO"
  (if (and (stringp default) (not (string-empty-p default)))
      (string-trim default)
    (if-let* ((context (or context (org-element-context)))
              (context (org-element-lineage context '(link) t))
              (beg (org-element-property :contents-begin context))
              (end (org-element-property :contents-end context)))
        (unless (= beg end)
          (replace-regexp-in-string
           "[ \n]+" " " (string-trim (buffer-substring-no-properties beg end)))))))

;;;###autoload
(defun +org-link-read-kbd-at-point (&optional default context)
  "TODO"
  (+org-link--describe-kbd
   (+org-link-read-desc-at-point default context)))

(defun +org-link--describe-kbd (keystr)
  (dolist (key `(("<leader>" . ,doom-leader-key)
                 ("<localleader>" . ,doom-localleader-key)
                 ("<prefix>" . ,(if (bound-and-true-p evil-mode)
                                    (concat doom-leader-key " u")
                                  "C-u"))
                 ("<help>" . ,(if (bound-and-true-p evil-mode)
                                  (concat doom-leader-key " h")
                                "C-h"))
                 ("\\<M-" . "alt-")
                 ("\\<S-" . "shift-")
                 ("\\<s-" . "super-")
                 ("\\<C-" . "ctrl-")))
    (setq keystr
          (replace-regexp-in-string (car key) (cdr key)
                                    keystr t t)))
  keystr)

(defun +org-link--read-module-spec (module-spec-str)
  (if (string-prefix-p "+" (string-trim-left module-spec-str))
      (let ((title (cadar (org-collect-keywords '("TITLE")))))
        (if (and title (string-match-p "\\`:[a-z]+ [A-Za-z0-9]+\\'" title))
            (+org-link--read-module-spec (concat title " " module-spec-str))
          (list :category nil :module nil :flag (intern module-spec-str))))
    (cl-destructuring-bind (category &optional module flag)
        (mapcar #'intern (split-string
                          (if (string-prefix-p ":" module-spec-str)
                              module-spec-str
                            (concat ":" module-spec-str))
                          "[ \n]+" nil))
      (list :category category
            :module module
            :flag flag))))

;;;###autoload
(defun +org-link--var-link-activate-fn (start end var _bracketed-p)
  (when buffer-read-only
    (add-text-properties
     start end
     (list 'display
           (concat
            #(" " 0 1
              (rear-nonsticky
               t display (raise 0.05)
               face (:family "github-octicons"
                     :inherit font-lock-variable-name-face
                     :height 0.8
                     :box (:line-width 1 :style none)))
              1 2 (face (:height 0.2)))
            var)))))

;;;###autoload
(defun +org-link--fn-link-activate-fn (start end fn _bracketed-p)
  (when buffer-read-only
    (add-text-properties
     start end
     (list 'display
           (concat
            #("λ " 0 1 (face (:inherit font-lock-function-name-face
                              :box (:line-width 1 :style none)
                              :height 0.9))
              1 2 (face (:height 0.2)))
            fn)))))

;;;###autoload
(defun +org-link--face-link-activate-face (start end face _bracketed-p)
  (when buffer-read-only
    (add-text-properties
     start end
     (list 'display
           (concat
            (propertize
             ""
             'rear-nonsticky t
             'display '(raise -0.02)
             'face (list '(:family "file-icons" :height 1.0)
                          (if (facep (intern face))
                              (intern face)
                            'default)
                          '(:underline nil)))
            #(" " 0 1 (face (:underline nil)))
            face)))))

(defun +org-link--command-keys (command)
  "Convert command reference TEXT to key binding representation."
  (let* ((cmd-prefix (mapcar #'reverse
                             (split-string (reverse command) " ")))
         (cmd (intern-soft (car cmd-prefix)))
         (prefix (and (cdr cmd-prefix)
                      (string-join (reverse (cdr cmd-prefix)) " ")))
         (key-binding (where-is-internal cmd nil t))
         (key-text (if key-binding
                       (key-description key-binding)
                     (format "M-x %s" cmd))))
    (concat prefix (and prefix " ") key-text)))

;;;###autoload
(defun +org-link--command-link-activate-command (start end command _bracketed-p)
  (when buffer-read-only
    (add-text-properties
     start end (list 'display (+org-link--command-keys command)))))

;;;###autoload
(defun +org-link--doom-module-link-follow-fn (module-path _arg)
  (cl-destructuring-bind (&key category module flag)
      (+org-link--read-module-spec module-path)
    (when category
      (let ((doom-modules-dirs (list doom-modules-dir)))
        (if-let* ((path (doom-module-locate-path category module))
                  (path (or (car (doom-glob path "README.org"))
                            path)))
            (find-file path)
          (user-error "Can't find Doom module '%s'" module-path))))
    (when flag
      (goto-char (point-min))
      (when (and (re-search-forward "^\\*+ \\(?:TODO \\)?Module flags")
                 (re-search-forward (format "^\\s-*- \\+%s ::[ \n]"
                                            (substring (symbol-name flag) 1))
                                    (save-excursion (org-get-next-sibling)
                                                    (point))))
        (org-show-entry)
        (recenter)))))

;;;###autoload
(defun +org-link--doom-module-link-face-fn (module-path)
  (cl-destructuring-bind (&key category module flag)
      (+org-link--read-module-spec module-path)
    (if (and category (doom-module-locate-path category module))
        `(:inherit org-priority
          :weight bold)
      'error)))

;;;###autoload
(defun +org-link--doom-module-link-activate-fn (start end module-path _bracketed-p)
  (when buffer-read-only
    (cl-destructuring-bind (&key category module flag)
        (+org-link--read-module-spec module-path)
      (let ((overall-face
             (cond
              ((doom-module-p category module flag)
               '((:underline nil) org-link org-block bold))
              ((and category (doom-module-locate-path category module))
               '(shadow org-block bold))
              (t '((:strike-through t) error org-block))))
            (icon-face
             (if (doom-module-p category module flag) 'success 'error)))
        (add-text-properties
         start end
         (list 'face overall-face
               'display
               (concat
                (propertize
                 " "
                 'rear-nonsticky t
                 'display '(raise -0.02)
                 'face `(:inherit ,icon-face
                         :family "FontAwesome"
                         :height 1.0))
                module-path)))))))

;;;###autoload
(defun +org-link--doom-package-link-activate-fn (start end package _bracketed-p)
  (when buffer-read-only
    (let ((overall-face
           (if (locate-library package)
               '((:underline nil) org-link org-block italic)
             '(shadow org-block italic)))
          (pkg-face
           (cond
            ((featurep (intern package)) 'success)
            ((locate-library package) 'warning)
            (t 'error))))
      (add-text-properties
       start end
       (list 'face overall-face
             'display
             (concat
              (propertize
               "\uf0c4" ; Octicon package symbol
               'rear-nonsticky t
               'display '(raise -0.02)
               'face `(:family "github-octicons" :height 1.0
                       :inherit ,pkg-face))
              " " package))))))

;;;###autoload
(defun +org-link-follow-doom-package-fn (pkg _prefixarg)
  "TODO"
  (doom/describe-package (intern-soft pkg)))

;;;###autoload
(defun +org-link--doom-executable-link-activate-fn (start end executable _bracketed-p)
  (when buffer-read-only
    (let ((found (executable-find executable)))
      (add-text-properties
       start end
       (list 'display
             (concat
              (nerd-icons-devicon "nf-dev-terminal_badge"
                                  :rear-nonsticky t
                                  :display '(raise -0.02)
                                  :face (list :height 1.0
                                              :inherit (if found 'success 'error)))
              " "
              (propertize
               executable
               'face (if found 'org-verbatim 'default))))))))

;;
;;; Help-echo / eldoc

(defadvice! doom-docs--display-docs-link-in-eldoc-a (&rest _)
  "Display help for doom-*: links in minibuffer when cursor/mouse is over it."
  :before-until #'org-eldoc-documentation-function
  (and (bound-and-true-p doom-docs-mode)
       (eq (get-text-property (point) 'help-echo)
           #'+org-link-doom--help-echo-from-textprop)
       (+org-link-doom--help-echo-from-textprop nil (current-buffer) (point))))

(defvar +org-link-doom--help-echo-cache nil)

(defun +org-link-doom--help-echo-from-textprop (_window object pos)
  (let ((link (with-current-buffer object
                (save-excursion (goto-char pos) (org-element-context)))))
    (if (eq (car +org-link-doom--help-echo-cache)
            (org-element-property :begin link))
        (cdr +org-link-doom--help-echo-cache)
      (cdr (setq +org-link-doom--help-echo-cache
                 (cons (org-element-property :begin link)
                       (+org-link-doom--help-string link)))))))

(defun +org-link-doom--help-string (link)
  (if (not buffer-read-only)
      (format "LINK: %s" (org-element-property :raw-link link))
    (pcase (org-element-property :type link)
      ("kbd"
       (concat
        "The key sequence "
        (propertize (+org-link--describe-kbd (org-element-property :path link))
                    'face 'help-key-binding)))
      ("cmd"
       (concat
        "The command "
        (propertize (org-element-property :path link) 'face 'font-lock-function-name-face)
        " can be invoked with the key sequence "
        (propertize (+org-link--command-keys (org-element-property :path link))
                    'face 'help-key-binding)))
      ("doom-package"
       (concat
        (propertize "Emacs package " 'face 'bold)
        (propertize (org-element-property :path link) 'face 'font-lock-keyword-face)
        ", currently "
        (cond
         ((featurep (intern-soft (org-element-property :path link)))
          (propertize "installed and loaded" 'face 'success))
         ((locate-library (org-element-property :path link))
          (propertize "installed but not loaded" 'face 'warning))
         (t (propertize "not installed" 'face 'error )))))
      ("doom-module"
       (concat
        (propertize "Doom module " 'face 'bold)
        (propertize (org-element-property :path link) 'face 'font-lock-keyword-face)
        ", currently "
        (cl-destructuring-bind (&key category module flag)
            (+org-link--read-module-spec (org-element-property :path link))
          (cond
           ((doom-module-p category module)
            (propertize "enabled" 'face 'success))
           ((and category (doom-module-locate-path category module))
            (propertize "disabled" 'face 'error))
           (t (propertize "unknown" 'face '(bold error)))))))
      ("doom-executable"
       (concat
        (propertize "System executable " 'face 'bold)
        (propertize (org-element-property :path link) 'face 'font-lock-keyword-face)
        ", "
        (if (executable-find (org-element-property :path link))
            (propertize "found" 'face 'success)
          (propertize "not found" 'face 'error))
        " on PATH")))))

;;
;;; Image data functions (for custom inline images)

;;;###autoload
(defun +org-image-file-data-fn (protocol link _description)
  "Intepret LINK as an image file path and return its data."
  (setq
   link (expand-file-name
         link (pcase protocol
                ("download"
                 (or (if (require 'org-download nil t) org-download-image-dir)
                     (if (require 'org-attach)         org-attach-id-dir)
                     default-directory))
                ("attachment"
                 (require 'org-attach)
                 org-attach-id-dir)
                (_ default-directory))))
  (when (and (file-exists-p link)
             (image-type-from-file-name link))
    (with-temp-buffer
      (set-buffer-multibyte nil)
      (setq buffer-file-coding-system 'binary)
      (insert-file-contents-literally link)
      (buffer-substring-no-properties (point-min) (point-max)))))

;;;###autoload
(defun +org-inline-image-data-fn (_protocol link _description)
  "Interpret LINK as base64-encoded image data."
  (base64-decode-string link))

;;;###autoload
(defun +org-http-image-data-fn (protocol link _description)
  "Interpret LINK as an URL to an image file."
  (when (and (image-type-from-file-name link)
             (not (eq org-display-remote-inline-images 'skip)))
    (if-let (buf (url-retrieve-synchronously (concat protocol ":" link)))
        (with-current-buffer buf
          (goto-char (point-min))
          (re-search-forward "\r?\n\r?\n" nil t)
          (buffer-substring-no-properties (point) (point-max)))
      (message "Download of image \"%s\" failed" link)
      nil)))

(defvar +org--gif-timers nil)
;;;###autoload
(defun +org-play-gif-at-point-h ()
  "Play the gif at point, while the cursor remains there (looping)."
  (dolist (timer +org--gif-timers (setq +org--gif-timers nil))
    (when (timerp (cdr timer))
      (cancel-timer (cdr timer)))
    (image-animate (car timer) nil 0))
  (when-let* ((ov (cl-find-if
                   (lambda (it) (overlay-get it 'org-image-overlay))
                   (overlays-at (point))))
              (dov (overlay-get ov 'display))
              (pt  (point)))
    (when (image-animated-p dov)
      (push (cons
             dov (run-with-idle-timer
                  0.5 nil
                  (lambda (dov)
                    (when (equal
                           ov (cl-find-if
                               (lambda (it) (overlay-get it 'org-image-overlay))
                               (overlays-at (point))))
                      (message "playing gif")
                      (image-animate dov nil t)))
                  dov))
            +org--gif-timers))))

;;;###autoload
(defun +org-play-all-gifs-h ()
  "Continuously play all gifs in the visible buffer."
  (dolist (ov (overlays-in (point-min) (point-max)))
    (when-let* (((overlay-get ov 'org-image-overlay))
                (dov (overlay-get ov 'display))
                ((image-animated-p dov))
                (w (selected-window)))
      (while-no-input
        (run-with-idle-timer
         0.3 nil
         (lambda (dov)
           (when (pos-visible-in-window-p (overlay-start ov) w nil)
             (unless (plist-get (cdr dov) :animate-buffer)
               (image-animate dov))))
         dov)))))


;;
;;; Commands

;;;###autoload
(defun +org/remove-link ()
  "Unlink the text at point."
  (interactive)
  (unless (org-in-regexp org-link-bracket-re 1)
    (user-error "No link at point"))
  (save-excursion
    (let ((label (if (match-end 2)
                     (match-string-no-properties 2)
                   (org-link-unescape (match-string-no-properties 1)))))
      (delete-region (match-beginning 0) (match-end 0))
      (insert label))))

;;;###autoload
(defun +org/play-gif-at-point ()
  "TODO"
  (interactive)
  (unless (eq 'org-mode major-mode)
    (user-error "Not in org-mode"))
  (or (+org-play-gif-at-point-h)
      (user-error "No gif at point")))