Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
276 lines (239 sloc) 8.63 KB
;;; thingopt.el --- Thing at Point optional utilities
;; Copyright (C) 2008-2015 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <>
;; 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
;; 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 <>.
;;; Commentary:
;; TODO documentation
;; TODO forward-string by syntax (?)
;;; Code:
(require 'cl))
(require 'thingatpt)
(defvar thing-list-cache nil)
(defvar upward-mark-thing-index 0)
(defvar upward-mark-thing-trial 0)
(defvar upward-mark-thing-original-position)
(defvar upward-mark-thing-list '(string symbol (up-list . *))
"List of types of things to mark for `upward-mark-thing'.")
(defvar upward-isearch-thing-list
'(email url word symbol string filename)
"Like `upward-mark-thing-list', but for `upward-isearch-thing'.")
(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)
(lambda (atom)
(if (thingp atom)
(push atom 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 reset-upward-bounds-of-thing ()
"Helper function for `upward-bounds-of-thing'."
(setq upward-bounds-of-thing-index 0
upward-bounds-of-thing-trial 0
upward-bounds-of-thing-original-position (point)
upward-bounds-of-thing-prev nil))
(defun upward-bounds-of-thing (list-of-things)
"Finds the location of the ends of a thing. LIST-OF-THINGS is
a list of types of things. Repeatedly calling this will take
successive types from the list and return the bounds of that
thing at point."
(let ((len (length list-of-things))
(index upward-bounds-of-thing-index)
(while (and (null bounds)
(< index len))
(let ((thing (nth index list-of-things))
(limit '*))
(if (consp thing)
(setq limit (cdr thing)
thing (car thing)))
(setq bounds (bounds-of-thing-at-point thing))
(if (not (or (null bounds)
(and (not (eq limit '*)) (>= upward-bounds-of-thing-trial limit))
(eq (car bounds) (cdr bounds))
(and upward-bounds-of-thing-prev
(equal bounds upward-bounds-of-thing-prev))))
(setq upward-bounds-of-thing-name (format "%s" (symbol-name thing)))
(setq bounds nil
index (mod (1+ index) len)
upward-bounds-of-thing-index (mod (1+ upward-bounds-of-thing-index) len)
upward-bounds-of-thing-trial 0)
(goto-char upward-bounds-of-thing-original-position))))
(when bounds
(setq upward-bounds-of-thing-trial (1+ upward-bounds-of-thing-trial))
(setq upward-bounds-of-thing-prev bounds)
(defun upward-mark-thing ()
"Marks the first type of thing in `upward-mark-thing-list' at
point. When called successively, it marks successive types of
things in `upward-mark-thing-list'. It is recommended to put
smaller things (e.g. word, symbol) before larger
things (e.g. list, paragraph) in `upward-mark-thing-list'. When
this is called enough times to get to the end of the list, it
wraps back to the first type of thing."
(unless (eq last-command this-command)
(let ((bounds (upward-bounds-of-thing upward-mark-thing-list)))
(when bounds
(message "%s" upward-bounds-of-thing-name)
(goto-char (car bounds))
(push-mark (cdr bounds) t 'activate)
(setq deactivate-mark nil))))
(defun upward-isearch-thing ()
"Much like `upward-mark-thing', but adds THING to the isearch string.
This should be invoked while isearch is active. Clobbers the current isearch string."
(unless (eq last-command this-command)
(let ((bounds (upward-bounds-of-thing upward-isearch-thing-list)))
(when bounds
(setq isearch-initial-string (buffer-substring-no-properties
(car bounds) (cdr bounds)))
(setq isearch-string isearch-initial-string
isearch-message isearch-initial-string)
(isearch-highlight (car bounds) (cdr bounds)))))
(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 'thingopt)))
(setq symbol (intern (format "%s-%s*" op thing))))
(put symbol 'thingopt 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))))
(funcall function (car bounds) (cdr bounds))
(message "Saved %s." thing))
(message "There is no %s here." thing))
(message "Nothing here."))))))
(defun kill-region-dwim ()
(kill-region-dwim-1 #'kill-region))
(defun kill-ring-save-dwim ()
(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))))
(defun forward-string (&optional arg)
(interactive "p")
(if (null arg)
(setq arg 1))
((> 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 ()
(let ((pos (scan-lists (point) -1 1)))
(goto-char pos)
(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))
((< 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 'thingopt)
;;; thingopt.el ends here