thingatpt-utils-base.el 1.0

[Andreas Roehler]

;;; thingatpt-utils-base.el --- thing-at-point edit functions

;; Version: 1.0

;; Copyright (C) 2006, 2007 Andreas Roehler

;; Author: Andreas Roehler <address@hidden>

;; Keywords: convenience

;;; Commentary: 

;; A set of functions to return, mover over or manipulate a
;; given THING. THING may be a well known form as
;; symbol', `list', `sexp', `defun' but also a new
;; defined and abstract thing.

;; The idea is to have a set of similar forms, which are quickly 
;; found that way. Many of them you probably
;; will never use; however it's easy thus to know which
;; facilities exist, should you need them. For example, to provide a
;; word with double-quotes around it, call
;; doublequote-word-atpt. In a similar way you may double-quote not
;; just a word, but any object instrumented here as THING. You
;; want to have parentheses around it? Call
;; parentize-word-atpt, etc.

;; To see other features, maybe try separate-list-atpt or
;; comment-list-atpt while point is inside a list. Try
;; it again with an abstract char-class as [:alnum:],
;; i.e. try comment-alnum-atpt, brace-alnum-atpt etc.

;; Call `list-of-things-atpt' to see which objects are presently 
;; instrumented.

;; All THINGS are provided with a set of functions at, before and
;; after point - i.e. to call with ACTION-THING-atpt,
;; -bfpt, afpt. Most before- and after-point-functions skip whitespaces
;; until first non-whitespace is reached, whereas ACTION-blank-bfpt
;; etc. skip non-whitespaces respectively. Thus functions which
;; call before- or after point forms presently only take effect, if
;; point is over a char, which is not part of THING; otherwise THING
;; at point is returned.

;; This utility comes with test-functions which return the possible 
;; results of most functions 
;; (exception are the kill-fns). Call thatpt-test,
;; thatpt-mv-test or thatpt-delimtest over text. 
;; Thatpt-delimtest changes but restores the buffer.
;; Customize the speed of execution via `thatpt-delimtest-delay' 
;; and `thatpt-mv-test-delay.'

;; Diffs to basics of required thingatpt.el: 
;; `bounds-of-thing-at-point' is replaced by a new 
;; `bounds-of-thatpt', which now first searches backward.
;; As a consequence several `beginning-op' and `end-op' constructs
;; had to be rewritten.

;; Behavior in general is not validating; i.e. if you call
;; url-atpt and there is no url, all chars at point may be picked,
;; which could be part of a url. Sometimes, however, a kind of
;; validation may be introduced.

;; In case of trouble, please send me a bug report. Any ideas and
;; comments welcome.

;; How it works: 

;; Thing-at-point delivers a portion of the buffer. This
;; substring is determined by two alternative ways:

;; - If a pair of move-functions is known, as forward-
;;   and backward-word, its used.
;; 
;; - A move-function specified for thingatpt, called
;;   beginning-op and end-op, may exist.
;; 
;; The latter case given, this form will be used
;; preferential. The point is stored after move.
;; Beginning and end are delivered as pair: as consed
;; bounds-of-thing. 
;; It's easy to write your own thing-at-point functions. 
;; You need three forms:
;; 
;; (defun MY-FORM-atpt (&optional arg ispec) 
;;   " "
;;   (interactive "p\np")
;;   (thatpt 'MY-FORM arg ispec))
;; 
;; (put 'MY-FORM 'beginning-op (lambda () MY-FORWARD-MOVE-FUNKTION))
;; (put 'MY-FORM 'end-op
;;      (lambda () MY-BACKWARD-MOVE-FUNKTION))
;; For example if you want to pick all chars at point
;; which are written between a string "AAA" and a
;; "BBB", which may exist as
;; AAA Luckily detected a lot of things! BBB
;; After evaluation of
;; (put 'MY-FORM 'beginning-op
;;      (lambda ()
;;        (search-backward "AAA" nil t 1)
;;        ;; step chars of search expression back
;;        (forward-char 3)))
;; 
;; (put 'MY-FORM 'end-op
;;      (lambda ()
;;        (search-forward "BBB" nil t 1)
;;        (forward-char -3)))
;; together with the functions definition above, it's ready.
;; M-x MY-FORM-atpt 
;; (while point inside) you should see: 
;; " Luckily detected a lot of things! " 
;; in the minibuffer.

;; Todo: Enable operation over a given number of things forward
;; or backward from point. (The form, which will take the numeric
;; argument is given already, but has no effect at the moment.)

;;; Code:

(require 'thingatpt)

(defvar thatpt-orig 0
  "Correct orig according to delimiter-length")


;; Ascii

(put 'ascii 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:ascii:]]")
       (skip-chars-backward "[:ascii:]"))))

(put 'ascii 'end-op
     (lambda ()
         (skip-chars-forward "[:ascii:]")))


;; Alnum

(put 'alnum 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:alnum:]]")
       (skip-chars-backward "[:alnum:]"))))

(put 'alnum 'end-op
     (lambda ()
         (skip-chars-forward "[:alnum:]")))


;; Alpha

(put 'alpha 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:alpha:]]")
       (skip-chars-backward "[:alpha:]"))))

(put 'alpha 'end-op
     (lambda ()
         (skip-chars-forward "[:alpha:]")))


;; Blank

(put 'blank 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:blank:]]")
       (skip-chars-backward "[:blank:]"))))

(put 'blank 'end-op
     (lambda ()
         (skip-chars-forward "[:blank:]")))


;; Cntrl

(put 'cntrl 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:cntrl:]]")
       (skip-chars-backward "[:cntrl:]"))))

(put 'cntrl 'end-op
     (lambda ()
         (skip-chars-forward "[:cntrl:]")))


;; Digit

(put 'digit 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:digit:]]")
       (skip-chars-backward "[:digit:]"))))

(put 'digit 'end-op
     (lambda ()
         (skip-chars-forward "[:digit:]")))


;; Graph

(put 'graph 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:graph:]]")
       (skip-chars-backward "[:graph:]"))))

(put 'graph 'end-op
     (lambda ()
         (skip-chars-forward "[:graph:]")))


;; Lower

(put 'lower 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:lower:]]")
       (skip-chars-backward "[:lower:]"))))

(put 'lower 'end-op
     (lambda ()
         (skip-chars-forward "[:lower:]")))


;; Multibyte

(put 'multibyte 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:multibyte:]]")
       (skip-chars-backward "[:multibyte:]"))))

(put 'multibyte 'end-op
     (lambda ()
         (skip-chars-forward "[:multibyte:]")))


;; Nonascii

(put 'nonascii 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:nonascii:]]")
       (skip-chars-backward "[:nonascii:]"))))

(put 'nonascii 'end-op
     (lambda ()
         (skip-chars-forward "[:nonascii:]")))


;; Print

(put 'print 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:print:]]")
       (skip-chars-backward "[:print:]"))))

(put 'print 'end-op
     (lambda ()
         (skip-chars-forward "[:print:]")))


;; Punct

(put 'punct 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:punct:]]")
       (skip-chars-backward "[:punct:]"))))

(put 'punct 'end-op
     (lambda ()
         (skip-chars-forward "[:punct:]")))


;; Space

(put 'space 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:space:]]")
       (skip-chars-backward "[:space:]"))))

(put 'space 'end-op
     (lambda ()
         (skip-chars-forward "[:space:]")))


;; Unibyte

(put 'unibyte 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:unibyte:]]")
       (skip-chars-backward "[:unibyte:]"))))

(put 'unibyte 'end-op
     (lambda ()
         (skip-chars-forward "[:unibyte:]")))


;; Upper

(put 'upper 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:upper:]]")
       (skip-chars-backward "[:upper:]"))))

(put 'upper 'end-op
     (lambda ()
         (skip-chars-forward "[:upper:]")))


;; Word

(put 'word 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:word:]]")
       (skip-chars-backward "[:word:]"))))

(put 'word 'end-op
     (lambda ()
         (skip-chars-forward "[:word:]")))


;; Xdigit

(put 'xdigit 'beginning-op
     (lambda ()
       (when
         (looking-at "[[:xdigit:]]")
       (skip-chars-backward "[:xdigit:]"))))

(put 'xdigit 'end-op
     (lambda ()
         (skip-chars-forward "[:xdigit:]")))



;;; CSV

;; Value of var `csv-separators' will be taken according to
;;; csv-mode.el --- major mode for editing comma-separated value files
;; Author: Francis J. Wright <F.J.Wright at qmul.ac.uk>
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/

(defcustom atpt-separator ";"
 "Char to distinguish datasets in a `comma`-separated row" 
:type 'string
:group 'convenience)

(if (boundp 'csv-separators)
  (setq separator-atpt csv-separators)
    (setq separator-atpt atpt-separator))

(put 'csv 'beginning-op
     (lambda ()
       (skip-chars-backward (concat "^" (car csv-separators)) 
(line-beginning-position))))

(put 'csv 'end-op
     (lambda ()
       (skip-chars-forward (concat "^" (car 
csv-separators))(line-end-position))))

;;; Symbol

(put 'symbol 'beginning-op
     (lambda ()
       (skip-syntax-backward "W_")))

(put 'symbol 'end-op
     (lambda ()
       (skip-syntax-forward "W_")))

;; Url

(put 'url 'beginning-op
     (lambda ()
       ;; provide for the case, we are over a
       ;; string-delimiter as `"'
       (when
           (and (not (eq 32 (char-after))) 
                (or (bobp)
                    (eq 32 (char-before))))
         (forward-char 1)
         ;; as the bounds-function checks position, correct it
         (setq thatpt-orig 1)) 
       (skip-chars-backward ":/address@hidden&'()*+,;=[:alnum:]-._~")
))

(put 'url 'end-op
     (lambda ()
         (skip-chars-forward ":/address@hidden&'()*+,;=[:alnum:]-._~")
         (skip-chars-backward ":")))

;; Phone

(put 'phone 'beginning-op
     (lambda ()
       (when
           (and (looking-at "[0-9 \t.()-]")
                (not (eq (char-before) ?+)))
       (re-search-backward "[^0-9 \t.()-][0-9 ()\t-]+" 
(line-beginning-position) t 1) (forward-char 1)))) 

(put 'phone 'end-op
     (lambda ()
       (when
           (looking-at "[0-9;, \t()-]")
         (re-search-forward "[0-9 \t.()-]+[^0-9 \t-]" (1+ (line-end-position)) 
t 1) (forward-char -1)))) 

;; Text
;; Useful to extract texts between ml-tags

(put 'ml-text 'beginning-op
     (lambda ()
       (when
           (looking-at "[^>]") 
         (re-search-backward ">" nil t 1)
         (forward-char 1)))) 

(put 'ml-text 'end-op (lambda () (re-search-forward "</" nil t 1) (forward-char 
-2))) 

;; Email

(put 'email 'beginning-op
     (lambda ()
       (when
           (looking-at "[^ \t]")
         (re-search-backward 
"[,;][[:graph:]]\\|<[[:graph:]]\\|^[[:graph:]]\\|[^[:graph:]][[:graph:]]" 
(line-beginning-position) t 1)(when (looking-at "[[:space:];,]") (forward-char 
1))))) 

;; (put 'email 'end-op (lambda () (re-search-forward 
"[[:graph:]]+>\\|[[:graph:address@hidden:graph:]]+[> \t\n]*" 
(line-end-position) t 1)))

(put 'email 'end-op (lambda () (when (looking-at "[ 
<]\\{0,1\\}\\([[:graph:address@hidden:graph:]]+\\)[;,> \t\n]*")
                                 (goto-char (match-end 1))
                                 (skip-chars-backward "[[:punct:]]"))))

;; ;; Graphs
;; obsolet by canonical regexp-classes forms above
;; 
;; (put 'graphs 'beginning-op (lambda () (when (looking-at "[^ \t]") 
(skip-chars-backward "[:graph:]"))))
;; 
;; (put 'graphs 'end-op (lambda () (skip-chars-forward "[:graph:]")))

;; Whitespace

(put 'whitespace 'beginning-op (lambda () (when (looking-at "[ \t]") 
(skip-chars-backward "[:blank:]"))))

(put 'whitespace 'end-op (lambda () (skip-chars-forward "[:blank:]")))

;; Number

(put 'number 'beginning-op (lambda () (when (numberp (read 
(buffer-substring-no-properties (point) (1+ (point)))))
    (skip-chars-backward "[0-9]"))))

(put 'number 'end-op
 (lambda ()
   (skip-chars-forward "[0-9]")))

;; Floats

(put 'float 'beginning-op (lambda () (when (numberp (read 
(buffer-substring-no-properties (point) (1+ (point)))))
    (skip-chars-backward "[0-9].,"))))

(put 'float 'end-op (lambda () (skip-chars-forward "[0-9.,]")))

;; Sexp

(defun beginning-of-sexp ()
  (let ((char-syntax (char-syntax (char-after (point)))))
    (if (eq char-syntax ?\))
        (backward-up-list)
      (when (and (eq char-syntax ?\") (in-string-p))
        (forward-char -1))
      (forward-sexp -1))))

;; Filename

(put 'filename 'beginning-op
     (lambda ()
       (re-search-backward (concat "[^" thing-at-point-file-name-chars "]") nil 
t)
       (forward-char 1)))

(put 'filename 'end-op
     (lambda ()
       (re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*")
                          nil t)
     (skip-chars-backward ": ")))

;; Defun

(put 'defun 'beginning-op (lambda (&optional arg) (beginning-of-defun (or arg 
1))))

(put 'defun 'end-op (lambda (&optional arg)(end-of-defun (or arg 1))))

;; Lines

(put 'line 'beginning-op (lambda () (beginning-of-line)))

;; Strings

(put 'string 'beginning-op  (lambda () (goto-char (with-syntax-table 
(standard-syntax-table) (nth 8 (syntax-ppss)))) 
;; (forward-char 1)
))

(put 'string 'end-op
     (lambda ()
       (let ((pos (progn (save-excursion (beginning-of-defun) (point))))) 
         (forward-char 1) 
         (while (not (eq (char-after) (nth 3 (with-syntax-table 
(standard-syntax-table) (parse-partial-sexp pos (point))))))
           (forward-char 1)))
       (forward-char 1))) 
   
;;  Lists  

(put 'list 'end-op (lambda () (forward-list 1)
)) 

(put 'list 'beginning-op
(lambda ()
  (or (looking-at "\\s(")
      (when (nth 9 (syntax-ppss))
        (goto-char (car (last (nth 9 (syntax-ppss)))))))))

(defun list-of-things-atpt ()
  "Displays a list of objects which might be called as THING herewith
Every THING is provided with a set of functions at, before and after point 
- i.e. to call with ACTION-THING-atpt,  -bfpt, afpt."
  (interactive)
  (message "%s" thatpt-forms-list))

(defun thatpt (thing &optional arg ispec) 
  "Returns a buffer substring according to THING.
THING may be a well known form as `symbol',
`list', `sexp', `defun'.
You may also define new and abstract kinds of THING.
See example given in thingatpt-util.el.
Called interactively, it always copies thing-at-point
as it's the most common use and faster than copy-thing.
Further functions with `thatpt' provide moves, transpositions.  
Call `list-of-things-atpt' to see what's implemented.
 "
  (let* ((bounds (bounds-of-thatpt thing arg))
         (type (if bounds
                   (buffer-substring-no-properties (car bounds) (cdr bounds))
                 nil)))
    (if ispec
        (if type
            (progn
              ;;              (if (eq thing 'whitespace)
              (kill-new type)
              ;;              (kill-new (string-strip type)))
              (message "%s" (car kill-ring)))
          (message "%s" "nil"))
      type)))

(defun bounds-of-thatpt (thing &optional arg move-flag)
  "Determine the start and end buffer locations for the THING at point.
     THING is a symbol which specifies the kind of syntactic entity you want.
     Possibilities include `symbol', `list', `sexp', `defun', `filename', `url',
     `word', `sentence', `whitespace', `line', `page' and others.
Call THING by his name, i.e. word-atpt etc., see `list-of-things-atpt' to see 
what's implemented"
  (condition-case nil
      (save-excursion
        (let ((orig (point))
              (beg (progn 
                     (funcall ;; First, move to beg.
                      (or (get thing 'beginning-op) 
                          (lambda ()
                            (forward-char 1)
                            (forward-thing thing -1))))
                     (point)))
              (end
               (progn (funcall ;; Then move to end.
                       (or (get thing 'end-op)
                           (lambda () (forward-thing thing 1))))
                      (point)))
              ;; jump back to see if pos is identic to beg 
              (jumped-back
               (progn 
                 (forward-char -1) 
                 (funcall 
                  (or (get thing 'beginning-op) 
                      (lambda ()
                        (forward-thing thing -1))))
                 (point))))
          ;; if orig not between beg and end, failure, nil
          (when (or move-flag
                    (and (= beg jumped-back) (<= beg (+ thatpt-orig orig)) (<= 
orig end) (< beg end)))
            (cons beg end))))
    (error nil)))

(defun thatpt-bounds (thing &optional arg ispec)
  "thatpt-bounds returns a cons (beg . end)
of THING if any suitable - nil otherwise.
Thatpt-beginning and thatpt-end return point."
  (let* ((bounds (bounds-of-thatpt thing arg))
         (start (car bounds))
         (end (cdr bounds)))
    (when ispec
      (message "%s %s" start end)) 
    (list start end)))

(defun thatpt-beginning (thing &optional arg ispec)
  (let* ((bounds (bounds-of-thatpt thing arg))
         (start (car bounds)))
    (when ispec
      (message "%s " start)) 
    start))

(defun thatpt-end (thing &optional arg ispec)
  (let* ((bounds (bounds-of-thatpt thing arg))
         (end (cdr bounds)))
    (when ispec
      (message "%s "  end)) 
    end))

(defun thatpt-copy (thing &optional arg ispec)
  (let ((newcopy (thatpt thing arg)))
    (if newcopy
        (progn
          (kill-new (thatpt thing arg))
          (if ispec
              (message "%s" (car kill-ring))
            (car kill-ring)))
      nil)))

(defun thatpt-separate (thing &optional arg ispec) 
  " "
  (interactive "*p\np")
  (save-excursion
    (let* ((bounds (bounds-of-thatpt thing arg))
           (beg (car bounds))
           (end (cdr bounds))
           (oldbufsize (buffer-size)))
      (if (and beg end)
          (progn 
            (when
                (<= (line-beginning-position) beg)
              (beginning-of-line)
              (untabify (point) beg)
              (unless (re-search-forward (concat "^[ ]\\{"(format "%s" (- beg 
(line-beginning-position)))"\\}") beg t 1) 
                (goto-char beg)
                (if (bobp)
                    (newline-and-indent)
                  (split-line))))
            (when
                (< oldbufsize (buffer-size)) 
              (setq end (+ end (- (buffer-size) oldbufsize)))
              (setq beg (+ beg (- (buffer-size) oldbufsize)))
              (setq oldbufsize (buffer-size)))
            (goto-char end)
            (cond ((eobp)
                   (newline-and-indent))
                  ((looking-at "[\t\r\n\f ]*$")
                   nil)
                  (t (split-line)))
            (when
                (< oldbufsize (buffer-size)) 
              (setq end (+ end (- (buffer-size) oldbufsize)))
              ;; (setq beg (+ beg (- (buffer-size) oldbufsize)))
              (setq oldbufsize (buffer-size))))
        nil)
      (list beg end))))

(defun thatpt-comment (thing &optional arg ispec) 
  " "
  (interactive "*p\np")
  (let* ((bounds (thatpt-separate thing arg ispec))
         (beg (car bounds))
         (end (cadr bounds)))
    (if (and beg end)
        (progn 
          (goto-char beg)
          (comment-or-uncomment-region beg (1+ end)))
      nil))) 

(defun thatpt-kill (thing &optional arg) 
  " "
  (let* ((arg (or arg 1))
         (bounds (bounds-of-thatpt thing arg)) 
         (start (car bounds))
         (end (cdr bounds)))
    (kill-region start end)))

(defun thatpt-forward (thing &optional arg ispec) 
  " "
  (interactive "p\np")
  (or arg (setq arg 1))
  (while (< 0 arg) 
    (let ((ep (cdr (bounds-of-thatpt thing arg t))))
      (when ep
        (goto-char ep)
        (when ispec
          (message "    %s" (point))))
      (setq arg (1- arg)))))

(defun thatpt-backward (thing &optional arg ispec) 
  " "
  (interactive "p\np")
  (or arg (setq arg 1))
  (while (< 0 arg)
    (let ((bp (car (bounds-of-thatpt thing arg t))))
      (when bp
        (goto-char bp)
        (when ispec
          (message "    %s" (point))))
      (setq arg (1- arg)))))

(defun thatpt-delim (thing action &optional arg ispec)
  "Process begin and end of region according to value of 
`delim-action\'
If no region is active, process borders of THING-at-point
according to value of delim-action-beginning- resp. -end-position
Default is symbol-atpt.
With \C-u or arg `escaped\' to `t\': insert escaped doublequotes"
  (interactive "*p\np")
  (or arg (setq arg 1)) 
  (save-excursion
    (let ((delim-insert (cond ((string= action "singlequote")
                               (cons ?\' ?\'))
                              ((string= action "doublequote")
                               (cons ?\" ?\"))
                              ((string= action "parentize")
                               (cons ?\( ?\)))
                              ((string= action "brace")
                               (cons ?\{ ?\}))
                              ((string= action "bracket")
                               (cons ?\[ ?\]))))
          (oldbufsize (buffer-size))
          (start (cond ((and mark-active transient-mark-mode)
                        (region-beginning))
                       ;;                      (t (funcall (intern-soft (concat 
(format "%s" thing)"-atpt-beginning-position"))))))
                       (t (funcall (intern-soft (concat (format "%s" 
thing)"-atpt-beginning-position"))))))
          (end (cond ((and mark-active transient-mark-mode)
                      (region-end))
                     (t (funcall (intern-soft (concat (format "%s" 
thing)"-atpt-end-position")))))))
      (if start
          (progn (goto-char start)
                 (insert (car delim-insert))
                 (if (< oldbufsize (buffer-size)) 
                     (setq end (+ end (- (buffer-size) oldbufsize)))
                   (setq end (- end (- oldbufsize (buffer-size)))))
                 (goto-char end)
                 (insert (cdr delim-insert)))))))

(provide 'thingatpt-utils-base)
;;; thingatpt-utils-base.el ends here