;;; easy-kill.el --- kill & mark things easily       -*- lexical-binding: t; -*-

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

;; Author: Leo Liu <sdl.web@gmail.com>
;; Version: 0.9.1
;; Package-Requires: ((emacs "24") (cl-lib "0.5"))
;; Keywords: killing, convenience
;; Created: 2013-08-12
;; URL: https://github.com/leoliu/easy-kill

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;; `easy-kill' aims to be a drop-in replacement for `kill-ring-save'.
;;
;; To use: (global-set-key [remap kill-ring-save] 'easy-kill)

;; `easy-mark' is similar to `easy-kill' but marks the region
;; immediately. It can be a handy replacement for `mark-sexp' allowing
;; `+'/`-' to do list-wise expanding/shrinking.
;;
;; To use: (global-set-key [remap mark-sexp] 'easy-mark)

;; Please send bug reports or feature requests to:
;;      https://github.com/leoliu/easy-kill/issues

;;; Code:

(require 'cl-lib)
(require 'thingatpt)

(eval-and-compile
  (cond
   ((fboundp 'set-transient-map) nil)
   ((fboundp 'set-temporary-overlay-map) ; new in 24.3
    (defalias 'set-transient-map 'set-temporary-overlay-map))
   (t
    (defun set-transient-map (map &optional keep-pred)
      (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
             (overlaysym (make-symbol "t"))
             (alist (list (cons overlaysym map)))
             (clearfun
              `(lambda ()
                 (unless ,(cond ((null keep-pred) nil)
                                ((eq t keep-pred)
                                 `(eq this-command
                                      (lookup-key ',map
                                                  (this-command-keys-vector))))
                                (t `(funcall ',keep-pred)))
                   (set ',overlaysym nil) ;Just in case.
                   (remove-hook 'pre-command-hook ',clearfunsym)
                   (setq emulation-mode-map-alists
                         (delq ',alist emulation-mode-map-alists))))))
        (set overlaysym overlaysym)
        (fset clearfunsym clearfun)
        (add-hook 'pre-command-hook clearfunsym)
        (push alist emulation-mode-map-alists))))))

(defcustom easy-kill-alist
  '((?w . word)
    (?s . sexp)
    (?l . list)
    (?f . filename)
    (?d . defun)
    (?e . line)
    (?b . buffer-file-name))
  "A list of (CHAR . THING).
CHAR is used immediately following `easy-kill' to select THING."
  :type '(repeat (cons character symbol))
  :group 'killing)

(defcustom easy-kill-try-things '(url email line)
  "A list of things for `easy-kill' to try."
  :type '(repeat symbol)
  :group 'killing)

(defcustom easy-mark-try-things '(url email sexp)
  "A list of things for `easy-mark' to try."
  :type '(repeat symbol)
  :group 'killing)

(defface easy-kill-selection '((t (:inherit secondary-selection)))
  "Faced used to highlight kill candidate."
  :group 'killing)

(defface easy-kill-origin '((t (:inverse-video t :inherit error)))
  "Faced used to highlight the origin."
  :group 'killing)

(defvar easy-kill-base-map
  (let ((map (make-sparse-keymap)))
    (define-key map "-" 'easy-kill-shrink)
    (define-key map "+" 'easy-kill-expand)
    (define-key map "=" 'easy-kill-expand)
    (define-key map "@" 'easy-kill-append)
    (define-key map [remap set-mark-command] 'easy-kill-mark-region)
    (define-key map [remap kill-region] 'easy-kill-region)
    (define-key map [remap keyboard-quit] 'easy-kill-abort)
    (mapc (lambda (d)
            (define-key map (number-to-string d) 'easy-kill-digit-argument))
          (number-sequence 0 9))
    map))

(defun easy-kill-map ()
  "Build the keymap according to `easy-kill-alist'."
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map easy-kill-base-map)
    (mapc (lambda (c)
            ;; (define-key map (vector meta-prefix-char c) 'easy-kill-select)
            (define-key map (char-to-string c) 'easy-kill-thing))
          (mapcar 'car easy-kill-alist))
    map))

(defvar easy-kill-inhibit-message nil)

(defun easy-kill-echo (format-string &rest args)
  "Same as `message' except not writing to *Messages* buffer.
Do nothing if `easy-kill-inhibit-message' is non-nil."
  (unless easy-kill-inhibit-message
    (let (message-log-max)
      (apply 'message format-string args))))

(defvar easy-kill-candidate nil)
(defvar easy-kill-append nil)
(defvar easy-kill-mark nil)

(defun easy-kill-init-candidate (n)
  (let ((o (make-overlay (point) (point))))
    (unless easy-kill-mark
      (overlay-put o 'face 'easy-kill-selection))
    (overlay-put o 'origin (point))
    ;; Use higher priority to avoid shadowing by, for example,
    ;; `hl-line-mode'.
    (overlay-put o 'priority 999)
    (when easy-kill-mark
      (let ((i (make-overlay (point) (point))))
        (overlay-put i 'priority (1+ (overlay-get o 'priority)))
        (overlay-put i 'face 'easy-kill-origin)
        (overlay-put i 'as (propertize " " 'face 'easy-kill-origin))
        (overlay-put o 'origin-indicator i)))
    (setq easy-kill-candidate o)
    (save-restriction
      ;; Work around http://debbugs.gnu.org/15808; not needed in 24.4.
      (narrow-to-region (max (point-min) (- (point) 1000))
                        (min (point-max) (+ (point) 1000)))
      (let ((easy-kill-inhibit-message t))
        (cl-dolist (thing easy-kill-try-things)
          (easy-kill-thing thing n)
          (or (string= (easy-kill-candidate) "")
              (cl-return)))))
    o))

(defun easy-kill-indicate-origin ()
  (let ((i (overlay-get easy-kill-candidate 'origin-indicator))
        (origin (overlay-get easy-kill-candidate 'origin)))
    (cond
     ((not (overlayp i)) nil)
     ((= origin (point))
      (overlay-put i 'after-string nil))
     ((memq (char-after origin) '(?\t ?\n))
      (overlay-put i 'after-string (overlay-get i 'as)))
     (t (move-overlay i origin (1+ origin))
        (overlay-put i 'after-string nil)))))

(defun easy-kill-candidate ()
  "Get the kill candidate as a string.
If the overlay specified by variable `easy-kill-candidate' has
non-zero length, it is the string covered by the overlay.
Otherwise, it is the value of the overlay's candidate property."
  (with-current-buffer (overlay-buffer easy-kill-candidate)
    (or (if (/= (overlay-start easy-kill-candidate)
                (overlay-end easy-kill-candidate))
            (filter-buffer-substring (overlay-start easy-kill-candidate)
                                     (overlay-end easy-kill-candidate))
          (overlay-get easy-kill-candidate 'candidate))
        "")))

(defun easy-kill-adjust-candidate (thing &optional beg end)
  "Adjust kill candidate to THING, BEG, END.
If BEG is a string, shrink the overlay to zero length and set its
candidate property instead."
  (let* ((o easy-kill-candidate)
         (beg (or beg (overlay-start o)))
         (end (or end (overlay-end o))))
    (overlay-put o 'thing thing)
    (if (stringp beg)
        (progn
          (move-overlay o (point) (point))
          (overlay-put o 'candidate beg)
          (let ((easy-kill-inhibit-message nil))
            (easy-kill-echo "%s" beg)))
      (move-overlay o beg end))
    (cond (easy-kill-mark (easy-kill-mark-region)
                          (easy-kill-indicate-origin))
          ((and interprogram-cut-function
                (not (string= (easy-kill-candidate) "")))
           (funcall interprogram-cut-function (easy-kill-candidate))))))

(defun easy-kill-save-candidate ()
  (unless (string= (easy-kill-candidate) "")
    ;; Don't modify the clipboard here since it is called in
    ;; `pre-command-hook' per `easy-kill-activate-keymap' and will
    ;; confuse `yank' if it is current command. Also
    ;; `easy-kill-adjust-candidate' already did that.
    (let ((interprogram-cut-function nil)
          (interprogram-paste-function nil))
      (kill-new (if easy-kill-append
                    (concat (car kill-ring) (easy-kill-candidate))
                  (easy-kill-candidate))
                easy-kill-append))
    t))

(defun easy-kill-destroy-candidate ()
  (let ((hook (make-symbol "easy-kill-destroy-candidate")))
    (fset hook `(lambda ()
                  (let ((o ,easy-kill-candidate))
                    (when o
                      (let ((i (overlay-get o 'origin-indicator)))
                        (and (overlayp i) (delete-overlay i)))
                      (delete-overlay o)))
                  (remove-hook 'post-command-hook ',hook)))
    ;; Run in `post-command-hook' so that exit commands can still use
    ;; `easy-kill-candidate'.
    (add-hook 'post-command-hook hook)))

(defun easy-kill-expand ()
  (interactive)
  (easy-kill-thing nil '+))

(defun easy-kill-digit-argument (n)
  (interactive
   (list (- (logand (if (integerp last-command-event)
                        last-command-event
                      (get last-command-event 'ascii-character))
                    ?\177)
            ?0)))
  (easy-kill-thing nil n))

(defun easy-kill-shrink ()
  (interactive)
  (easy-kill-thing nil '-))

;; helper for `easy-kill-thing'.
(defun easy-kill-thing-forward (n)
  (let ((thing (overlay-get easy-kill-candidate 'thing))
        (direction (if (cl-minusp n) -1 +1))
        (start (overlay-start easy-kill-candidate))
        (end (overlay-end easy-kill-candidate)))
    (when (and thing (/= n 0))
      (let ((new-end (save-excursion
                       (goto-char end)
                       (with-demoted-errors
                         (cl-dotimes (_ (abs n))
                           (forward-thing thing direction)
                           (when (<= (point) start)
                             (forward-thing thing 1)
                             (cl-return))))
                       (point))))
        (when (/= end new-end)
          (easy-kill-adjust-candidate thing nil new-end)
          t)))))

(defun easy-kill-thing (&optional thing n inhibit-handler)
  ;; N can be -, + and digits
  (interactive
   (list (cdr (assq last-command-event easy-kill-alist))
         (prefix-numeric-value current-prefix-arg)))
  (let ((thing (or thing (overlay-get easy-kill-candidate 'thing)))
        (n (or n 1)))
    (when easy-kill-mark
      (goto-char (overlay-get easy-kill-candidate 'origin)))
    (cond
     ((and (not inhibit-handler)
           (fboundp (intern-soft (format "easy-kill-on-%s" thing))))
      (funcall (intern (format "easy-kill-on-%s" thing)) n))
     ((or (eq thing (overlay-get easy-kill-candidate 'thing))
          (memq n '(+ -)))
      (easy-kill-thing-forward (pcase n
                                 (`+ 1)
                                 (`- -1)
                                 (_ n))))
     (t (pcase (bounds-of-thing-at-point thing)
          (`nil (easy-kill-echo "No `%s'" thing))
          (`(,start . ,end)
           (easy-kill-adjust-candidate thing start end)
           (easy-kill-thing-forward (1- n))))))
    (when easy-kill-mark
      (easy-kill-adjust-candidate (overlay-get easy-kill-candidate 'thing)))))

(put 'easy-kill-abort 'easy-kill-exit t)
(defun easy-kill-abort ()
  (interactive)
  (when easy-kill-mark
    ;; The after-string may interfere with `goto-char'.
    (overlay-put (overlay-get easy-kill-candidate 'origin-indicator)
                 'after-string nil)
    (goto-char (overlay-get easy-kill-candidate 'origin))
    (setq deactivate-mark t))
  (ding))

(put 'easy-kill-region 'easy-kill-exit t)
(defun easy-kill-region ()
  "Kill current selection and exit."
  (interactive "*")
  (let ((beg (overlay-start easy-kill-candidate))
        (end (overlay-end easy-kill-candidate)))
    (if (= beg end)
        (easy-kill-echo "Empty region")
      (kill-region beg end))))

(put 'easy-kill-mark-region 'easy-kill-exit t)
(defun easy-kill-mark-region ()
  (interactive)
  (let ((beg (overlay-start easy-kill-candidate))
        (end (overlay-end easy-kill-candidate)))
    (if (= beg end)
        (easy-kill-echo "Empty region")
      (set-mark beg)
      (goto-char end)
      (activate-mark))))

(put 'easy-kill-append 'easy-kill-exit t)
(defun easy-kill-append ()
  (interactive)
  (setq easy-kill-append t)
  (when (easy-kill-save-candidate)
    (and interprogram-cut-function
         (funcall interprogram-cut-function (car kill-ring)))
    (setq deactivate-mark t)
    (easy-kill-echo "Appended")))

(defun easy-kill-activate-keymap ()
  (let ((map (easy-kill-map)))
    (set-transient-map
     map
     (lambda ()
       ;; Prevent any error from activating the keymap forever.
       (condition-case err
           (or (and (not (and (symbolp this-command)
                              (get this-command 'easy-kill-exit)))
                    (or (eq this-command
                            (lookup-key map (this-single-command-keys)))
                        (let ((cmd (key-binding
                                    (this-single-command-keys) nil t)))
                          (command-remapping cmd nil (list map)))))
               (ignore
                (easy-kill-destroy-candidate)
                (unless (or easy-kill-mark
                            (and (symbolp this-command)
                                 (get this-command 'easy-kill-exit)))
                  (easy-kill-save-candidate))))
         (error (message "%s:%s" this-command (error-message-string err))
                nil))))))

;;;###autoload
(defun easy-kill (&optional n)
  "Kill thing at point in the order of region, url, email and line.
Temporally activate additional key bindings as follows:

  letters => select or expand selection according to `easy-kill-alist';
  0..9    => expand selection by that number;
  +,=/-   => expand or shrink selection;
  @       => append selection to previous kill;
  C-w     => kill selection;
  C-SPC   => turn selection into an active region;
  C-g     => abort;
  others  => save selection and exit."
  (interactive "p")
  (if (use-region-p)
      (if (fboundp 'rectangle-mark-mode) ; New in 24.4
          (with-no-warnings
            (kill-ring-save (region-beginning) (region-end) t))
        (kill-ring-save (region-beginning) (region-end)))
    (setq easy-kill-mark nil)
    (setq easy-kill-append (eq last-command 'kill-region))
    (easy-kill-init-candidate n)
    (when (zerop (buffer-size))
      (easy-kill-echo "Warn: `easy-kill' activated in empty buffer"))
    (easy-kill-activate-keymap)))

;;;###autoload
(defalias 'easy-mark-sexp 'easy-mark
  "Use `easy-mark' instead. The alias may be removed in future.")

;;;###autoload
(defun easy-mark (&optional n)
  "Similar to `easy-kill' (which see) but for marking."
  (interactive "p")
  (let ((easy-kill-try-things easy-mark-try-things))
    (setq easy-kill-mark t)
    (easy-kill-init-candidate n)
    (easy-kill-activate-keymap)
    (unless (overlay-get easy-kill-candidate 'thing)
      (overlay-put easy-kill-candidate 'thing 'sexp)
      (easy-kill-thing 'sexp n))))

;;;; Extended things

;;; Handler for `buffer-file-name'.

(defun easy-kill-on-buffer-file-name (n)
  "Get `buffer-file-name' or `default-directory'.
If N is zero, remove the directory part; -, remove the file name
part; +, full path."
  (if easy-kill-mark
      (easy-kill-echo "Not supported in `easy-mark'")
    (let ((file (or buffer-file-name default-directory)))
      (when file
        (let* ((file (directory-file-name file))
               (text (pcase n
                       (`- (file-name-directory file))
                       ((pred (eq 0)) (file-name-nondirectory file))
                       (_ file))))
          (easy-kill-adjust-candidate 'buffer-file-name text))))))

;;; Handler for `defun-name'.

(defun easy-kill-on-defun-name (_n)
  "Get current defun name."
  (if easy-kill-mark
      (easy-kill-echo "Not supported in `easy-mark'")
    (let ((defun-name (add-log-current-defun)))
      (if defun-name
          (easy-kill-adjust-candidate 'defun-name defun-name)
        (easy-kill-echo "No `defun-name' at point")))))

;;; Handler for `url'.

(defun easy-kill-on-url (&optional _n)
  "Get url at point or from char properties.
Char properties `help-echo', `shr-url' and `w3m-href-anchor' are
inspected."
  (if (or easy-kill-mark (bounds-of-thing-at-point 'url))
      (easy-kill-thing 'url nil t)
    (cl-labels ((get-url (text)
                         (when (stringp text)
                           (with-temp-buffer
                             (insert text)
                             (and (bounds-of-thing-at-point 'url)
                                  (thing-at-point 'url))))))
      (cl-dolist (p '(help-echo shr-url w3m-href-anchor))
        (pcase-let* ((`(,text . ,ov)
                      (get-char-property-and-overlay (point) p))
                     (url (or (get-url text)
                              (get-url (and ov (overlay-get ov p))))))
          (when url
            (easy-kill-adjust-candidate 'url url)
            (cl-return url)))))))

;;; Handler for `sexp' and `list'.

(defvar up-list-fn)                     ; Dynamically bound

(defun easy-kill-backward-up ()
  (let ((ppss (syntax-ppss)))
    (condition-case nil
        (progn
          (funcall (or (bound-and-true-p up-list-fn) #'up-list) -1)
          ;; `up-list' may jump to another string.
          (when (and (nth 3 ppss) (< (point) (nth 8 ppss)))
            (goto-char (nth 8 ppss))))
      (scan-error (and (nth 3 ppss) (goto-char (nth 8 ppss)))))))

(defun easy-kill-forward-down (point &optional bound)
  (condition-case nil
      (progn
        (easy-kill-backward-up)
        (backward-prefix-chars)
        (if (and (or (not bound) (> (point) bound))
                 (/= point (point)))
            (easy-kill-forward-down (point) bound)
          (goto-char point)))
    (scan-error (goto-char point))))

(defun easy-kill-bounds-of-list (n)
  (save-excursion
    (pcase n
      (`+ (goto-char (overlay-start easy-kill-candidate))
          (easy-kill-backward-up))
      (`- (easy-kill-forward-down
           (point) (overlay-start easy-kill-candidate)))
      (_ (error "Unsupported argument `%s'" n)))
    (bounds-of-thing-at-point 'sexp)))

(defvar nxml-sexp-element-flag)

(defun easy-kill-on-nxml-element (n)
  (let ((nxml-sexp-element-flag t)
        (up-list-fn 'nxml-up-element))
    (cond
     ((memq n '(+ -))
      (let ((bounds (easy-kill-bounds-of-list n)))
        (when bounds
          (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
     ((eq 'list (overlay-get easy-kill-candidate 'thing))
      (let ((new-end (save-excursion
                       (goto-char (overlay-end easy-kill-candidate))
                       (forward-sexp n)
                       (point))))
        (when (and new-end (/= new-end (overlay-end easy-kill-candidate)))
          (easy-kill-adjust-candidate 'list nil new-end))))
     (t (save-excursion
          (ignore-errors (easy-kill-backward-up))
          (easy-kill-thing 'sexp n t)
          (overlay-put easy-kill-candidate 'thing 'list))))))

(defun easy-kill-find-js2-node (beg end &optional inner)
  (eval-and-compile (require 'js2-mode))
  (let* ((node (js2-node-at-point))
         (last-node node))
    (while (progn
             (if (or (js2-ast-root-p node)
                     (and (<= (js2-node-abs-pos node) beg)
                          (>= (js2-node-abs-end node) end)
                          (or inner
                              (not (and (= (js2-node-abs-pos node) beg)
                                        (= (js2-node-abs-end node) end))))))
                 nil
               (setq last-node node
                     node (js2-node-parent node))
               t)))
    (if inner last-node node)))

(defun easy-kill-on-js2-node (n)
  (let ((node (pcase n
                ((or `+ `-)
                 (easy-kill-find-js2-node (overlay-start easy-kill-candidate)
                                          (overlay-end easy-kill-candidate)
                                          (eq n '-)))
                ((guard (eq 'list (overlay-get easy-kill-candidate 'thing)))
                 (error "List forward not supported in js2-mode"))
                (_ (js2-node-at-point)))))
    (easy-kill-adjust-candidate 'list
                                (js2-node-abs-pos node)
                                (js2-node-abs-end node))))

(defun easy-kill-on-list (n)
  (cond
   ((derived-mode-p 'nxml-mode)
    (easy-kill-on-nxml-element n))
   ((derived-mode-p 'js2-mode)
    (easy-kill-on-js2-node n))
   ((memq n '(+ -))
    (let ((bounds (easy-kill-bounds-of-list n)))
      (when bounds
        (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
   (t (easy-kill-thing 'list n t))))

(defun easy-kill-on-sexp (n)
  (if (memq n '(+ -))
      (easy-kill-on-list n)
    (easy-kill-thing 'sexp n t)))

(provide 'easy-kill)
;;; easy-kill.el ends here