Download
(eval-when-compile
(require 'cl))
(require 'thingatpt)
(defvar thing-list-cache nil)
(defvar upward-mark-thing-index 0)
(defvar upward-mark-thing-list '(string symbol (up-list . *)))
(defvar upward-mark-thing-trial 0)
(defvar upward-mark-thing-original-position)
(defun thingp (thing)
(or (get thing 'bounds-of-thing-at-point)
(get thing 'forward-op)
(get thing 'beginning-op)
(get thing 'end-op)
(fboundp (intern-soft (concat "forward-" (symbol-name thing))))))
(defun list-thing ()
(let (things)
(mapatoms
(lambda (atom)
(if (thingp atom)
(push atom things))))
things))
(defun read-thing ()
(or thing-list-cache
(setq thing-list-cache (list-thing)))
(completing-read "Thing: " (mapcar 'list thing-list-cache)
nil nil nil nil "sexp"))
(defun kill-thing (thing)
(interactive (list (read-thing)))
(if (stringp thing)
(setq thing (intern thing)))
(let ((bounds (bounds-of-thing-at-point thing)))
(if bounds
(kill-region (car bounds) (cdr bounds)))))
(defun copy-thing (thing)
(interactive (list (read-thing)))
(if (stringp thing)
(setq thing (intern thing)))
(let ((bounds (bounds-of-thing-at-point thing)))
(if bounds
(copy-region-as-kill (car bounds) (cdr bounds)))))
(defun mark-thing (thing)
(interactive (list (read-thing)))
(if (stringp thing)
(setq thing (intern thing)))
(let ((bounds (bounds-of-thing-at-point thing)))
(when bounds
(goto-char (car bounds))
(push-mark (cdr bounds) nil transient-mark-mode)
(setq deactivate-mark nil))))
(defun upward-mark-thing ()
(interactive)
(if (not (eq last-command this-command))
(setq upward-mark-thing-index 0
upward-mark-thing-trial 0
upward-mark-thing-original-position (point)))
(let ((index upward-mark-thing-index)
(length (length upward-mark-thing-list))
bounds)
(while (and (null bounds)
(< index length))
(let ((thing (nth index upward-mark-thing-list))
(limit '*))
(if (consp thing)
(setq limit (cdr thing)
thing (car thing)))
(setq bounds (bounds-of-thing-at-point thing))
(when (or (null bounds)
(and (not (eq limit '*)) (>= upward-mark-thing-trial limit))
(eq (car bounds) (cdr bounds))
(and mark-active
(eq (car bounds) (point))
(eq (cdr bounds) (mark))))
(setq bounds nil
index (1+ index)
upward-mark-thing-index (1+ upward-mark-thing-index)
upward-mark-thing-trial 0)
(goto-char upward-mark-thing-original-position))))
(when bounds
(setq upward-mark-thing-trial (1+ upward-mark-thing-trial))
(goto-char (car bounds))
(push-mark (cdr bounds) t 'activate)
(setq deactivate-mark nil))))
(defun define-thing-commands ()
(dolist (thing (list-thing))
(dolist (op '(mark kill copy))
(let ((symbol (intern (format "%s-%s" op thing))))
(if (and (fboundp symbol)
(not (get symbol 'thing-opt)))
(setq symbol (intern (format "%s-%s*" op thing))))
(put symbol 'thing-opt t)
(fset symbol `(lambda () (interactive) (,(intern (format "%s-thing" op)) ',thing)))))))
(defvar kill-thing-map
'((?w . word)
(?e . sexp)
(?s . symbol)
(?t . sentence)
(?p . paragraph)
(?f . defun)
(?F . filename)
(?l . list)
(?L . up-list)
(?S . string)
(?U . url)
(?P . page)))
(defun kill-region-dwim-1 (function)
(if (and transient-mark-mode mark-active)
(call-interactively function)
(let* ((c (read-char))
(thing (assoc-default c kill-thing-map))
(bounds (if thing (bounds-of-thing-at-point thing))))
(cond
(bounds
(funcall function (car bounds) (cdr bounds))
(message "Saved %s." thing))
(thing
(message "There is no %s here." thing))
(t
(message "Nothing here."))))))
(defun kill-region-dwim ()
(interactive)
(kill-region-dwim-1 'kill-region))
(defun kill-ring-save-dwim ()
(interactive)
(kill-region-dwim-1 'kill-ring-save))
(defun string-face-p (face)
(let (result)
(or (consp face)
(setq face (list face)))
(while (and face (null result))
(if (memq (car face) '(font-lock-string-face font-lock-doc-face))
(setq result t)
(setq face (cdr face))))
result))
(defun forward-string (&optional arg)
(interactive "p")
(if (null arg)
(setq arg 1))
(ignore-errors
(cond
((> arg 0)
(dotimes (i arg)
(while (and (re-search-forward "\\s\"")
(string-face-p (get-text-property (point) 'face))))))
((< arg 0)
(dotimes (i (- arg))
(while (and (re-search-backward "\\s\"")
(string-face-p (get-text-property (1- (point)) 'face)))))))))
(defun backward-string (&optional arg)
(interactive "p")
(forward-string (- (or arg 1))))
(defun bounds-of-up-list-at-point ()
(ignore-errors
(save-excursion
(let ((pos (scan-lists (point) -1 1)))
(goto-char pos)
(forward-list)
(cons pos (point))))))
(put 'up-list 'bounds-of-thing-at-point (symbol-function 'bounds-of-up-list-at-point))
(defun forward-defun (&optional arg)
(interactive "p")
(if (null arg)
(setq arg 1))
(ignore-errors
(cond
((< arg 0)
(beginning-of-defun (- arg)))
((> arg 0)
(end-of-defun arg)))))
(defun backward-defun (&optional arg)
(interactive "p")
(forward-defun (- (or arg 1))))
(provide 'thing-opt)