;;; do-at-point.el --- Generic context-sensitive action dispatcher.  -*- lexical-binding: t; -*-

;; Copyright (C) 2023, 2024, 2025, 2026  Free Software Foundation, Inc.

;; Author: Philip Kaludercic <philipk@posteo.net>
;; Maintainer: Philip Kaludercic <philipk@posteo.net>
;; URL: https://codeberg.org/pkal/do-at-point.el
;; Version: 0.2.0-pre
;; Package-Requires: ((emacs "26.1"))
;; Keywords: convenience

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

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

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

;;; Commentary:

;; The command `do-at-point' is a generalised `find-file-at-point',
;; both in the sense that it can understand more than just files, and
;; do more than just open a file.  Depending on the "thing" at point,
;; different "actions" can be dispatched, e.g. opening a url using
;; `browse-url' or occurring a symbol at point.

;; The main entry point of this package is `do-at-point'.  Bind it to
;; a convenient key:
;;
;;   (global-set-key (kbd "C-'") #'do-at-point)
;;
;; Also take a look at `do-at-point-dwim'.
;;
;; Most of the behaviour is controlled via the user option
;; `do-at-point-actions' and `do-at-point-user-actions'.  A mode may
;; use `do-at-point-local-actions' to add additional things and/or
;; actions.

;; Inspired by Embark and `isearch-forward-thing-at-point'.

;;; News:

;;;; Version 0.2.0

;; - Add new command `do-at-point-dwim'.  It will automatically run
;;   the first action on the first thing `do-at-point' would select.
;;   With a prefix argument, you can inspect what that action would
;;   be.
;; - Add new action on URLs to clone Git repositories into /tamp/
;; - Add new action to attach files to Gnus
;; - Add new action to run "rgrep" on some text
;; - Add new action to integrate Iedit (if installed)
;; - Prioritise matching symbols before words in the cycle order
;; - Improve robustness of `do-at-point-forward' and
;;   `do-at-point-backward'.

;;; Code:

(eval-when-compile (require 'pcase))
(require 'seq)
(require 'thingatpt)

(defgroup do-at-point '()
  "Generic context-sensitive action dispatcher."
  :group 'convenience)

(defconst do-at-point--actions-type
  '(alist :value-type
          (alist :value-type
                 (choice
                  (const :tag "Inherit" nil)
                  (list :tag "Action"
                        (string :tag "Description") function))
                 :key-type character)
          :key-type symbol)
  "User option type for `do-at-point' actions.")

(defcustom do-at-point-user-actions '()
  "Custom association of things and their respective actions.
Refer to the user option `do-at-point-actions' for details on the
structure of the values of this user option."
  :type do-at-point--actions-type)

(defvar-local do-at-point-local-actions '()
  "Actions that can be added by a major or minor mode.
These are prioritised to the user option `do-at-point-actions',
but not `do-at-point-user-actions'.  Refer to the user option
`do-at-point-actions' for details on the structure of the values
of this variable.")

(declare-function gnus-dired-attach "gnus-dired" (files-to-attach))

(defcustom do-at-point-actions
  `((region
     (?\s "Mark" ,(lambda (start end)
                    (set-mark start)
                    (goto-char end)))
     (?\C-i "Indent" ,#'indent-region)
     (?s "Isearch"
         ,(lambda (str)
            (isearch-mode t)
            (isearch-yank-string str)))
     (?o "Occur" ,(lambda (str) (occur (regexp-quote str))))
     (?w "Kill-Save" ,#'kill-new)
     (?W "Write region"
         ,(lambda (beg end)
            (let ((file (read-file-name "File: ")))
              (write-region beg end file))))
     (?k "Kill" ,#'kill-region)
     (?n "Narrow" ,#'narrow-to-region)
     (?g "Grep" ,(lambda (str)
                   (rgrep (regexp-quote str) "*" ".")))
     (?$ "Spell check" ,#'ispell-region)
     (?| "Pipe command"
         ,(lambda (beg end)
            (let ((cmd (read-shell-command "Command: ")))
              (shell-command-on-region beg end cmd nil t))))
     (?! "Shell command" ,(if (fboundp 'shell-command+)
                              #'shell-command+
                            (lambda (cmd) (shell-command cmd))))
     (?h "Highlight" ,(eval-when-compile
                        (require 'hi-lock)
                        (lambda (str)
                          (let ((hi-lock-auto-select-face t))
                            (highlight-regexp
                             (regexp-quote str)
                             (hi-lock-read-face-name))))))
     (?y "Yank & Swap"
         ,(lambda (start end)
            (let ((str (delete-and-extract-region start end)))
              (insert-for-yank (current-kill 0))
              (kill-new str t))))
     (?\C-? "Delete" ,#'delete-region)
     ,@(and (fboundp 'iedit-mode)
            `((?i "Iedit" ,(lambda (start end)
                             (set-mark start)
                             (goto-char end)
                             (funcall-interactively 'iedit-mode))))))
    (email
     (?m "Compose message" ,(lambda (to) (compose-mail to))))
    (existing-filename
     (?f "Find file" ,#'find-file)
     (?4 "Find file other window" ,#'find-file-other-window)
     (?a "Attach to message"
         ,(lambda (path)
            (require 'gnus-dired)
            (gnus-dired-attach (list path)))))
    (url
     (?b "Browse" ,#'browse-url)
     (?d "Download" ,#'(lambda (url)
                         (cond
                          ((executable-find "wget")
                           (start-process "*Download*" nil "wget" "-q" "-c" url))
                          ((executable-find "wcurl")
                           (start-process "*Download*" nil "wcurl" url))
                          ;; FIXME: We should also try falling back to
                          ;; `url-retrieve'.
                          ((error "Failed to find external executable for downloads")))))
     (?g "git-clone into temp"
         ,(lambda (url)
            (let ((dir (make-temp-file (file-name-base url) t))
                  (default-directory temporary-file-directory))
              (call-process "git" nil nil nil "clone" url dir)
              (find-file-other-window dir))))
     (?e "eww" ,#'eww-browse-url))
    (number
     (?* "Calc" ,(lambda () (calc-embedded '(t)))))
    (symbol
     (?. "Xref" ,#'xref-find-definitions)
     (?o "Occur" ,(lambda (str)
                    (occur (concat "\\_<\\(" (regexp-quote str) "\\)\\_>")))))
    (word
     (?$ "Spell check" ,(lambda () (ispell-word)))
     (?d "Dictionary" ,#'dictionary-search)
     (?t "Transpose" ,(lambda () (transpose-words (or current-prefix-arg 1)))))
    (string)
    (sexp
     (?t "Transpose" ,(lambda () (transpose-sexps (or current-prefix-arg 1)))))
    (line
     (?t "Transpose" ,(lambda () (transpose-lines (or current-prefix-arg 1)))))
    (paragraph
     (?$)
     (?t "Transpose" ,(lambda () (transpose-paragraphs (or current-prefix-arg 1)))))
    (defun
        (?e "Evaluate" ,(lambda () (eval-defun nil)))))
  "Association of things and their respective actions.
Each element of the list has the form (THING . ACTIONS), where
THING is a symbol as interpreted by `thing-at-point' and ACTIONS
have the form (KEY NAME FUNC), where KEY is a dispatch character,
NAME is a brief description of the action and FUNC is a function
that will be dispatched when KEY is selected.  FUNC can take
zero, one or two arguments, which `do-at-point' will respectively
interpret as function that is invoked without any arguments, or
with a buffer substring or the bounds of THING.  Actions listed
under the \"thing\" `region' are shared among all \"things\".  An
entry in ACTIONS can omit NAME and FUNC, and it will instead
fallback into the entry for `region'.  This is why a an entry
does not require any actions to be associated with it, if it just
serves as a specific kind of region worth selecting.  The order
of element in the list correspond to the order in which
`do-at-point' will prompt the user for possible things at point.
Note that the user option `do-at-point-user-actions' and the
variable `do-at-point-local-actions' take precedence over this
user option."
  :type do-at-point--actions-type)

(defcustom do-at-point-quick-bindings t
  "Non-nil means that quick bindings are enabled.
Quick bindings allow for the user to operate on a selection
without having to have confirmed the first."
  :type 'boolean)

(defcustom do-at-point-quick-confirm-key (kbd "<return>")
  "The key to bind the quick confirm command to.
See `do-at-point-quick-bindings' for the meaning of quick
confirm."
  :type 'key-sequence)

(defcustom do-at-point-selection-face 'highlight
  "Face to use to highlight the selected thing."
  :type 'face)

(defvar do-at-point--quick-map (make-sparse-keymap))

(defun do-at-point--actions (thing)
  "Return possible actions for THING.
The function consults `do-at-point-user-actions',
`do-at-point-local-actions' and the user option
`do-at-point-actions' in this order and inherits actions from
more to less specific entries."
  (seq-reduce
   (lambda (accum ent)
     (let ((prev (assq (car ent) accum)))
       (cons (list (car ent)
                   (or (cadr ent) (cadr prev))
                   (or (caddr ent) (caddr prev))
                   (or (cadddr ent) (cadddr prev)))
             (delq prev accum))))
   (reverse (append
             (alist-get thing do-at-point-user-actions)
             (alist-get 'region do-at-point-user-actions)
             (alist-get thing do-at-point-local-actions)
             (alist-get 'region do-at-point-local-actions)
             (alist-get thing do-at-point-actions)
             (alist-get 'region do-at-point-actions)))
   '()))

(defvar-local do-at-point--overlay nil
  "Buffer-local overlay object to display the selection overlay.
The overlay is also used to store properties like the current
thing being selected and the key used to invoke `do-at-point'.")

(defun do-at-point--update ()
  "Ensure a consistent state for the \"thing\" at point.
This means updating and moving the selection overlay and ensuring
that the repeat key, i.e. the key which was used to initially
invoke `do-at-point' is bound transiently."
  (let ((thing (or (overlay-get do-at-point--overlay 'do-at-point-thing)
                   (do-at-point--next-thing t))))
    (let ((bound (bounds-of-thing-at-point thing)))
      (if bound
          (move-overlay do-at-point--overlay (car bound) (cdr bound))
        (delete-overlay do-at-point--overlay)))
    (set-transient-map
     (let ((map (make-sparse-keymap)))
       (define-key map (vector (overlay-get do-at-point--overlay 'do-at-point-key))
                   #'do-at-point--next-thing)
       map))))

(defvar do-at-point-persist-mode)

(defun do-at-point-confirm (&optional quick dry-run)
  "Dispatch an action on the current \"thing\" being selected.
If the optional argument QUICK is non-nil, the first applicable action
is selected.  If DRY-RUN is non-nil, then only display the name of the
selected action."
  (interactive)
  (unless (and do-at-point--overlay
               (overlay-start do-at-point--overlay)
               (overlay-end do-at-point--overlay))
    (user-error "No selected thing"))
  (let* ((thing (overlay-get do-at-point--overlay 'do-at-point-thing))
         (options (do-at-point--actions thing))
         (choice (cond
                  (quick (car options))
                  ((assq last-command-event options))
                  ((condition-case nil
                       (read-multiple-choice
                        (format "Action on %s" thing)
                        (mapcar
                         (pcase-lambda (`(,key ,short ,_func ,long))
                           (list key short long))
                         options))
                     (quit nil)))))
         (func (cadr (alist-get (car choice) options)))
         (bound (cons (overlay-start do-at-point--overlay)
                      (overlay-end do-at-point--overlay))))
    (unless do-at-point-persist-mode
      (do-at-point--mode -1))
    (when func
      (message nil)               ;clear mini buffer
      (pcase (car (func-arity func))
        ((guard dry-run)
         (message "Would do: %s on %s" (cadr choice) thing))
        (0 (funcall func))
        (1 (funcall func (buffer-substring (car bound) (cdr bound))))
        (2 (funcall func (car bound) (cdr bound)))
        (_ (error "Unsupported signature: %S" func))))))

;; We add an alias for to avoid confusing `substitute-key-definition'
;; later on.
(defalias 'do-at-point-confirm* #'do-at-point-confirm)

(defun do-at-point-confirm-quick ()
  "Quickly select the first action for the selected \"thing\".
See the function `do-at-point-confirm' for more details."
  (interactive)
  (do-at-point-confirm t))

(defun do-at-point-quit ()
  "Quit the selection mode and defer to \\[keyboard-quit]."
  (interactive)
  (do-at-point--mode -1)
  (do-at-point-persist-mode -1)
  (keyboard-quit))

(defun do-at-point--applicable-things ()
  "Return a list of things that are applicable at point."
  (let ((actions (append do-at-point-user-actions
                         do-at-point-local-actions
                         do-at-point-actions)))
    (seq-filter #'thing-at-point (mapcar #'car actions))))

(defun do-at-point--next-thing (&optional no-update)
  "Select the next possible \"thing\".
If NO-UPDATE is nil, then the selection overlay is also updated.
Otherwise the next \"thing\" is just determined.  The return
value of the function is always the new \"thing\"."
  (interactive)
  (let* ((things (do-at-point--applicable-things))
         (thing (overlay-get do-at-point--overlay 'do-at-point-thing)))
    (setq thing (or (cadr (memq thing things)) (car things)))
    (prog1 (overlay-put do-at-point--overlay 'do-at-point-thing thing)
      ;; clear and reinitialise the shortcut map
      (setcdr do-at-point--quick-map nil)
      (when do-at-point-quick-bindings
        (dolist (key (mapcar #'car (do-at-point--actions thing)))
          (define-key do-at-point--quick-map (vector key) #'do-at-point-confirm))
        (define-key do-at-point--quick-map do-at-point-quick-confirm-key
                    #'do-at-point-confirm-quick))
      (let ((default (cadar (do-at-point--actions thing))))
        (message
         (substitute-command-keys
          "Act on `%s' (%s by default), select using \\[do-at-point-confirm*].")
         thing default))
      (unless no-update
        (do-at-point--update)))))

(defun do-at-point--lighter ()
  "Determine the lighter for `do-at-point--mode'.
The lighter depends on the current \"thing\" being selected."
  (let ((thing (overlay-get do-at-point--overlay 'do-at-point-thing)))
    (and thing (format " Do-At-Point/%s%s" thing
                       (if do-at-point-persist-mode "*" "")))))

(defvar do-at-point--mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map do-at-point--quick-map)
    (define-key map (kbd "C-<return>") #'do-at-point-confirm*)
    (define-key map (kbd "M-<return>") #'do-at-point-persist-mode)
    (define-key map [remap keyboard-quit] #'do-at-point-quit)
    (define-key map (kbd "M-n") #'do-at-point-forward)
    (define-key map (kbd "M-p") #'do-at-point-backward)
    map))

(defvar do-at-point-hook '()
  "Hook run after enabling and disabling `do-at-point' selection.")

(define-minor-mode do-at-point--mode
  "Minor mode that implements the selection for `do-at-point'.
This is an internal implementation detail and shouldn't be
invoked or bound directly.  Use the command `do-at-point'
instead."
  :lighter ((:eval (do-at-point--lighter)))
  :interactive nil
  (if do-at-point--mode
      (let ((ov (let ((ov (make-overlay 0 0)))
                  (overlay-put ov 'face do-at-point-selection-face)
                  (delete-overlay ov)
                  ov)))
        (overlay-put ov 'do-at-point-key last-command-event)
        (add-hook 'post-command-hook #'do-at-point--update 90 t)
        (setq do-at-point--overlay ov)
        (do-at-point--update))
    (remove-hook 'post-command-hook #'do-at-point--update t)
    (when do-at-point--overlay
      (overlay-put do-at-point--overlay 'do-at-point-thing nil)
      (delete-overlay do-at-point--overlay))
    (setq do-at-point--overlay nil))
  (run-hooks 'do-at-point-hook))

(define-minor-mode do-at-point-persist-mode
  "Minor mode that inhibits `do-at-point' from disabling itself.
This is useful if you want to execute multiple actions in sequence,
without having to re-select the object repeatedly."
  :global nil)

(defun do-at-point-forward (n)
   "Move focus N things ahead.
By default, this will move one thing ahead."
   (interactive "p")
   (when do-at-point--overlay
     (let ((begin (overlay-start do-at-point--overlay))
           (thing (overlay-get do-at-point--overlay 'do-at-point-thing))
           (same 0))                     ;retry-counter
       (if (and begin thing)
           ;; The `same' counter gives us two attempts to move to the
           ;; next "thing."  If we just try once without repeating, we
           ;; can stay on the same "thing", which sometimes is a
           ;; problem with paragraphs.  If we don't limit the number
           ;; of repetitions, we don't terminate if we are at the end
           ;; of a buffer and there are no more things, hence we
           ;; remain at the same point.
           (while (and (<= same 1) (eq begin (car (bounds-of-thing-at-point thing))))
             (let ((before (point)))
               (forward-thing thing n)
               (setq same (if (= before (point)) (1+ same) 0))))
         (forward-thing thing n)))))

(defun do-at-point-backward (n)
   "Move focus N things back.
Refer to the command `do-at-point-forward' for more details."
   (interactive "p")
   (do-at-point-forward (- (or n 1))))

;;;###autoload
(defun do-at-point (&optional thing)
  "Focus on a THING at point.
If invoked interactively with a prefix argument or with the
optional argument THING, one can set the initial thing to be
selected."
  (interactive
   (let ((things (do-at-point--applicable-things)))
     (if (null current-prefix-arg) '()
       (unless things
         (user-error "Nothing applicable at point to choose"))
       (list (intern (completing-read "Thing: " things nil t))))))
  (when thing
    (setq do-at-point--overlay (copy-overlay do-at-point--overlay))
    (overlay-put do-at-point--overlay 'do-at-point-thing thing))
  (when do-at-point--mode
    (do-at-point--mode -1))
  (do-at-point--mode 1))

;;;###autoload (put 'do-at-point 'setup-func 'do-at-point)

;;;###autoload
(defun do-at-point-dwim (dry-run)
  "Immediately execute first action for the first thing at point.
If invoked with a prefix argument (or non-interactively with a non-nil
value for DRY-RUN), then this command will only display the name of the
action it would perform."
  (interactive "P")
  (unwind-protect
      (let ((do-at-point-persist-mode nil))
        (do-at-point--mode 1)
        (do-at-point-confirm t dry-run))
    (when do-at-point--mode
      (do-at-point--mode -1))))

(provide 'do-at-point)
;;; do-at-point.el ends here
