;;; evil-macros.el --- Macros
;; Author: Vegard Øye <vegard_oye at hotmail.com>
;; Maintainer: Vegard Øye <vegard_oye at hotmail.com>
;; Version: 1.2.13
;;
;; This file is NOT part of GNU Emacs.
;;; License:
;; This file is part of Evil.
;;
;; Evil 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.
;;
;; Evil 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 Evil. If not, see <http://www.gnu.org/licenses/>.
(require 'evil-common)
(require 'evil-states)
(require 'evil-repeat)
;;; Code:
(declare-function evil-ex-p "evil-ex")
;; set some error codes
(put 'beginning-of-line 'error-conditions '(beginning-of-line error))
(put 'beginning-of-line 'error-message "Beginning of line")
(put 'end-of-line 'error-conditions '(end-of-line error))
(put 'end-of-line 'error-message "End of line")
(defun evil-motion-range (motion &optional count type)
"Execute a motion and return the buffer positions.
The return value is a list (BEG END TYPE)."
(let ((opoint (point))
(omark (mark t))
(omactive (and (boundp 'mark-active) mark-active))
(obuffer (current-buffer))
(evil-motion-marker (move-marker (make-marker) (point)))
range)
(evil-with-transient-mark-mode
(evil-narrow-to-field
(unwind-protect
(let ((current-prefix-arg count)
;; Store type in global variable `evil-this-type'.
;; If necessary, motions can change their type
;; during execution by setting this variable.
(evil-this-type
(or type (evil-type motion 'exclusive))))
(condition-case err
(let ((repeat-type (evil-repeat-type motion t)))
(if (functionp repeat-type)
(funcall repeat-type 'pre))
(unless (with-local-quit
(setq range (call-interactively motion))
t)
(evil-repeat-abort)
(setq quit-flag t))
(if (functionp repeat-type)
(funcall repeat-type 'post)))
(error (prog1 nil
(evil-repeat-abort)
;; some operators depend on succeeding
;; motions, in particular for
;; `evil-forward-char' (e.g., used by
;; `evil-substitute'), therefore we let
;; end-of-line and end-of-buffer pass
(if (not (memq (car err) '(end-of-line end-of-buffer)))
(signal (car err) (cdr err))
(message (error-message-string err))))))
(cond
;; the motion returned a range
((evil-range-p range))
;; the motion made a Visual selection
((evil-visual-state-p)
(setq range (evil-visual-range)))
;; the motion made an active region
((region-active-p)
(setq range (evil-range (region-beginning)
(region-end)
evil-this-type)))
;; default: range from previous position to current
(t
(setq range (evil-expand-range
(evil-normalize evil-motion-marker
(point)
evil-this-type)))))
(unless (or (null type) (eq (evil-type range) type))
(evil-set-type range type)
(evil-expand-range range))
(evil-set-range-properties range nil)
range)
;; restore point and mark like `save-excursion',
;; but only if the motion hasn't disabled the operator
(unless evil-inhibit-operator
(set-buffer obuffer)
(evil-move-mark omark)
(goto-char opoint))
;; delete marker so it doesn't slow down editing
(move-marker evil-motion-marker nil))))))
(defmacro evil-define-motion (motion args &rest body)
"Define an motion command MOTION.
\(fn MOTION (COUNT ARGS...) DOC [[KEY VALUE]...] BODY...)"
(declare (indent defun)
(debug (&define name lambda-list
[&optional stringp]
[&rest keywordp sexp]
[&optional ("interactive" [&rest form])]
def-body)))
(let (arg doc interactive key keys type)
(when args
(setq args `(&optional ,@(delq '&optional args))
;; the count is either numerical or nil
interactive '("<c>")))
;; collect docstring
(when (and (> (length body) 1)
(or (eq (car-safe (car-safe body)) 'format)
(stringp (car-safe body))))
(setq doc (pop body)))
;; collect keywords
(setq keys (plist-put keys :repeat 'motion))
(while (keywordp (car-safe body))
(setq key (pop body)
arg (pop body)
keys (plist-put keys key arg)))
;; collect `interactive' specification
(when (eq (car-safe (car-safe body)) 'interactive)
(setq interactive (cdr (pop body))))
;; macro expansion
`(progn
;; refresh echo area in Eldoc mode
(when ',motion
(eval-after-load 'eldoc
'(and (fboundp 'eldoc-add-command)
(eldoc-add-command ',motion))))
(evil-define-command ,motion (,@args)
,@(when doc `(,doc)) ; avoid nil before `interactive'
,@keys
:keep-visual t
(interactive ,@interactive)
,@body))))
(defmacro evil-narrow-to-line (&rest body)
"Narrow BODY to the current line.
BODY will signal the errors 'beginning-of-line or 'end-of-line
upon reaching the beginning or end of the current line.
\(fn [[KEY VAL]...] BODY...)"
(declare (indent defun)
(debug t))
`(let* ((range (evil-expand (point) (point) 'line))
(beg (evil-range-beginning range))
(end (evil-range-end range))
(min (point-min))
(max (point-max)))
(when (save-excursion (goto-char end) (bolp))
(setq end (max beg (1- end))))
;; don't include the newline in Normal state
(when (and evil-move-cursor-back
(not evil-move-beyond-eol)
(not (evil-visual-state-p))
(not (evil-operator-state-p)))
(setq end (max beg (1- end))))
(evil-with-restriction beg end
(evil-signal-without-movement
(condition-case err
(progn ,@body)
(beginning-of-buffer
(if (= beg min)
(signal (car err) (cdr err))
(signal 'beginning-of-line nil)))
(end-of-buffer
(if (= end max)
(signal (car err) (cdr err))
(signal 'end-of-line nil))))))))
;; we don't want line boundaries to trigger the debugger
;; when `debug-on-error' is t
(add-to-list 'debug-ignored-errors "^Beginning of line$")
(add-to-list 'debug-ignored-errors "^End of line$")
(defun evil-eobp (&optional pos)
"Whether point is at end-of-buffer with regard to end-of-line."
(save-excursion
(when pos (goto-char pos))
(cond
((eobp))
;; the rest only pertains to Normal state
((not (evil-normal-state-p))
nil)
;; at the end of the last line
((eolp)
(forward-char)
(eobp))
;; at the last character of the last line
(t
(forward-char)
(cond
((eobp))
((eolp)
(forward-char)
(eobp)))))))
(defun evil-move-beginning (count forward &optional backward)
"Move to the beginning of the COUNT next object.
If COUNT is negative, move to the COUNT previous object.
FORWARD is a function which moves to the end of the object, and
BACKWARD is a function which moves to the beginning.
If one is unspecified, the other is used with a negative argument."
(let* ((count (or count 1))
(backward (or backward
#'(lambda (count)
(funcall forward (- count)))))
(forward (or forward
#'(lambda (count)
(funcall backward (- count)))))
(opoint (point)))
(cond
((< count 0)
(when (bobp)
(signal 'beginning-of-buffer nil))
(unwind-protect
(evil-motion-loop (nil count count)
(funcall backward 1))
(unless (zerop count)
(goto-char (point-min)))))
((> count 0)
(when (evil-eobp)
(signal 'end-of-buffer nil))
;; Do we need to move past the current object?
(when (<= (save-excursion
(funcall forward 1)
(funcall backward 1)
(point))
opoint)
(setq count (1+ count)))
(unwind-protect
(evil-motion-loop (nil count count)
(funcall forward 1))
(if (zerop count)
;; go back to beginning of object
(funcall backward 1)
(goto-char (point-max)))))
(t
count))))
(defun evil-move-end (count forward &optional backward inclusive)
"Move to the end of the COUNT next object.
If COUNT is negative, move to the COUNT previous object.
FORWARD is a function which moves to the end of the object, and
BACKWARD is a function which moves to the beginning.
If one is unspecified, the other is used with a negative argument.
If INCLUSIVE is non-nil, then point is placed at the last character
of the object; otherwise it is placed at the end of the object."
(let* ((count (or count 1))
(backward (or backward
#'(lambda (count)
(funcall forward (- count)))))
(forward (or forward
#'(lambda (count)
(funcall backward (- count)))))
(opoint (point)))
(cond
((< count 0)
(when (bobp)
(signal 'beginning-of-buffer nil))
;; Do we need to move past the current object?
(when (>= (save-excursion
(funcall backward 1)
(funcall forward 1)
(point))
(if inclusive
(1+ opoint)
opoint))
(setq count (1- count)))
(unwind-protect
(evil-motion-loop (nil count count)
(funcall backward 1))
(if (not (zerop count))
(goto-char (point-min))
;; go to end of object
(funcall forward 1)
(when inclusive
(unless (bobp) (backward-char)))
(when (or (evil-normal-state-p)
(evil-motion-state-p))
(evil-adjust-cursor t)))))
((> count 0)
(when (evil-eobp)
(signal 'end-of-buffer nil))
(when inclusive
(forward-char))
(unwind-protect
(evil-motion-loop (nil count count)
(funcall forward 1))
(if (not (zerop count))
(goto-char (point-max))
(when inclusive
(unless (bobp) (backward-char)))
(when (or (evil-normal-state-p)
(evil-motion-state-p))
(evil-adjust-cursor t)))))
(t
count))))
(defun evil-text-object-make-linewise (range)
"Turn the text object selection RANGE to linewise.
The selection is adjusted in a sensible way so that the selected
lines match the user intent. In particular, whitespace-only parts
at the first and last lines are omitted. This function returns
the new range."
;; Bug #607
;; If new type is linewise and the selection of the
;; first line consists of whitespace only, the
;; beginning is moved to the start of the next line. If
;; the selections of the last line consists of
;; whitespace only, the end is moved to the end of the
;; previous line.
(if (eq (evil-type range) 'line)
range
(let ((expanded (plist-get (evil-range-properties range) :expanded))
(newrange (evil-expand-range range t)))
(save-excursion
;; skip whitespace at the beginning
(goto-char (evil-range-beginning newrange))
(skip-chars-forward " \t")
(when (and (not (bolp)) (eolp))
(evil-set-range-beginning newrange (1+ (point))))
;; skip whitepsace at the end
(goto-char (evil-range-end newrange))
(skip-chars-backward " \t")
(when (and (not (eolp)) (bolp))
(evil-set-range-end newrange (1- (point))))
;; only modify range if result is not empty
(if (> (evil-range-beginning newrange)
(evil-range-end newrange))
range
(unless expanded
(evil-contract-range newrange))
newrange)))))
(defmacro evil-define-text-object (object args &rest body)
"Define a text object command OBJECT.
BODY should return a range (BEG END) to the right of point
if COUNT is positive, and to the left of it if negative.
\(fn OBJECT (COUNT) DOC [[KEY VALUE]...] BODY...)"
(declare (indent defun)
(debug (&define name lambda-list
[&optional stringp]
[&rest keywordp sexp]
def-body)))
(let* ((args (delq '&optional args))
(count (or (pop args) 'count))
(args (when args `(&optional ,@args)))
(interactive '((interactive "<c><v>")))
arg doc key keys)
;; collect docstring
(when (stringp (car-safe body))
(setq doc (pop body)))
;; collect keywords
(setq keys (plist-put keys :extend-selection t))
(while (keywordp (car-safe body))
(setq key (pop body)
arg (pop body)
keys (plist-put keys key arg)))
;; interactive
(when (eq (car-safe (car-safe body)) 'interactive)
(setq interactive (list (pop body))))
;; macro expansion
`(evil-define-motion ,object (,count ,@args)
,@(when doc `(,doc))
,@keys
,@interactive
(setq ,count (or ,count 1))
(when (/= ,count 0)
(let ((type (evil-type ',object evil-visual-char))
(extend (and (evil-visual-state-p)
(evil-get-command-property
',object :extend-selection
',(plist-get keys :extend-selection))))
(dir evil-visual-direction)
mark point range selection)
(cond
;; Visual state: extend the current selection
((and (evil-visual-state-p)
(called-interactively-p 'any))
;; if we are at the beginning of the Visual selection,
;; go to the left (negative COUNT); if at the end,
;; go to the right (positive COUNT)
(setq dir evil-visual-direction
,count (* ,count dir))
(setq range (progn ,@body))
(when (evil-range-p range)
(setq range (evil-expand-range range))
(evil-set-type range (evil-type range type))
(setq range (evil-contract-range range))
;; the beginning is mark and the end is point
;; unless the selection goes the other way
(setq mark (evil-range-beginning range)
point (evil-range-end range)
type (evil-type
(if evil-text-object-change-visual-type
range
(evil-visual-range))))
(when (and (eq type 'line)
(not (eq type (evil-type range))))
(let ((newrange (evil-text-object-make-linewise range)))
(setq mark (evil-range-beginning newrange)
point (evil-range-end newrange))))
(when (< dir 0)
(evil-swap mark point))
;; select the union
(evil-visual-make-selection mark point type)))
;; not Visual state: return a pair of buffer positions
(t
(setq range (progn ,@body))
(unless (evil-range-p range)
(setq ,count (- ,count)
range (progn ,@body)))
(when (evil-range-p range)
(setq selection (evil-range (point) (point) type))
(if extend
(setq range (evil-range-union range selection))
(evil-set-type range (evil-type range type)))
;; possibly convert to linewise
(when (eq evil-this-type-modified 'line)
(setq range (evil-text-object-make-linewise range)))
(evil-set-range-properties range nil)
range))))))))
(defmacro evil-define-operator (operator args &rest body)
"Define an operator command OPERATOR.
\(fn OPERATOR (BEG END ARGS...) DOC [[KEY VALUE]...] BODY...)"
(declare (indent defun)
(debug (&define name lambda-list
[&optional stringp]
[&rest keywordp sexp]
[&optional ("interactive" [&rest form])]
def-body)))
(let* ((args (delq '&optional args))
(interactive (if (> (length args) 2) '("<R>") '("<r>")))
(args (if (> (length args) 2)
`(,(nth 0 args) ,(nth 1 args)
&optional ,@(nthcdr 2 args))
args))
arg doc key keys visual)
;; collect docstring
(when (and (> (length body) 1)
(or (eq (car-safe (car-safe body)) 'format)
(stringp (car-safe body))))
(setq doc (pop body)))
;; collect keywords
(setq keys (plist-put keys :move-point t))
(while (keywordp (car-safe body))
(setq key (pop body)
arg (pop body))
(cond
((eq key :keep-visual)
(setq visual arg))
(t
(setq keys (plist-put keys key arg)))))
;; collect `interactive' specification
(when (eq (car-safe (car-safe body)) 'interactive)
(setq interactive (cdr-safe (pop body))))
;; transform extended interactive specs
(setq interactive (apply #'evil-interactive-form interactive))
(setq keys (evil-concat-plists keys (cdr-safe interactive))
interactive (car-safe interactive))
;; macro expansion
`(evil-define-command ,operator ,args
,@(when doc `(,doc))
,@keys
:keep-visual t
:suppress-operator t
(interactive
(let* ((evil-operator-range-motion
(when (evil-has-command-property-p ',operator :motion)
;; :motion nil is equivalent to :motion undefined
(or (evil-get-command-property ',operator :motion)
#'undefined)))
(evil-operator-range-type
(evil-get-command-property ',operator :type))
(orig (point))
evil-operator-range-beginning
evil-operator-range-end
evil-inhibit-operator)
(setq evil-inhibit-operator-value nil
evil-this-operator this-command)
(prog1 ,interactive
(setq orig (point)
evil-inhibit-operator-value evil-inhibit-operator)
(if ,visual
(when (evil-visual-state-p)
(evil-visual-expand-region))
(when (or (evil-visual-state-p) (region-active-p))
(setq deactivate-mark t)))
(cond
((evil-visual-state-p)
(evil-visual-rotate 'upper-left))
((evil-get-command-property ',operator :move-point)
(goto-char (or evil-operator-range-beginning orig)))
(t
(goto-char orig))))))
(unwind-protect
(let ((evil-inhibit-operator evil-inhibit-operator-value))
(unless (and evil-inhibit-operator
(called-interactively-p 'any))
,@body))
(setq evil-inhibit-operator-value nil)))))
;; this is used in the `interactive' specification of an operator command
(defun evil-operator-range (&optional return-type)
"Read a motion from the keyboard and return its buffer positions.
The return value is a list (BEG END), or (BEG END TYPE) if
RETURN-TYPE is non-nil."
(let* ((evil-ex-p (and (not (minibufferp)) (evil-ex-p)))
(motion (or evil-operator-range-motion
(when evil-ex-p 'evil-line)))
(type evil-operator-range-type)
(range (evil-range (point) (point)))
command count modifier)
(setq evil-this-type-modified nil)
(evil-save-echo-area
(cond
;; Ex mode
((and evil-ex-p evil-ex-range)
(setq range evil-ex-range))
;; Visual selection
((and (not evil-ex-p) (evil-visual-state-p))
(setq range (evil-visual-range)))
;; active region
((and (not evil-ex-p) (region-active-p))
(setq range (evil-range (region-beginning)
(region-end)
(or evil-this-type 'exclusive))))
(t
;; motion
(evil-save-state
(unless motion
(evil-change-state 'operator)
;; Make linewise operator shortcuts. E.g., "d" yields the
;; shortcut "dd", and "g?" yields shortcuts "g??" and "g?g?".
(let ((keys (nth 2 (evil-extract-count (this-command-keys)))))
(setq keys (listify-key-sequence keys))
(dotimes (var (length keys))
(define-key evil-operator-shortcut-map
(vconcat (nthcdr var keys)) 'evil-line)))
;; read motion from keyboard
(setq command (evil-read-motion motion)
motion (nth 0 command)
count (nth 1 command)
type (or type (nth 2 command))))
(cond
((eq motion #'undefined)
(setq range (if return-type '(nil nil nil) '(nil nil))
motion nil))
((or (null motion) ; keyboard-quit
(evil-get-command-property motion :suppress-operator))
(when (fboundp 'evil-repeat-abort)
(evil-repeat-abort))
(setq quit-flag t
motion nil))
(evil-repeat-count
(setq count evil-repeat-count
;; only the first operator's count is overwritten
evil-repeat-count nil))
((or count current-prefix-arg)
;; multiply operator count and motion count together
(setq count
(* (prefix-numeric-value count)
(prefix-numeric-value current-prefix-arg)))))
(when motion
(let ((evil-state 'operator)
mark-active)
;; calculate motion range
(setq range (evil-motion-range
motion
count
type))))
;; update global variables
(setq evil-this-motion motion
evil-this-motion-count count
type (evil-type range type)
evil-this-type type))))
(when (evil-range-p range)
(unless (or (null type) (eq (evil-type range) type))
(evil-contract-range range)
(evil-set-type range type)
(evil-expand-range range))
(evil-set-range-properties range nil)
(unless return-type
(evil-set-type range nil))
(setq evil-operator-range-beginning (evil-range-beginning range)
evil-operator-range-end (evil-range-end range)
evil-operator-range-type (evil-type range)))
range)))
(defmacro evil-define-type (type doc &rest body)
"Define type TYPE.
DOC is a general description and shows up in all docstrings.
It is followed by a list of keywords and functions:
:expand FUNC Expansion function. This function should accept
two positions in the current buffer, BEG and END,
and return a pair of expanded buffer positions.
:contract FUNC The opposite of :expand, optional.
:one-to-one BOOL Whether expansion is one-to-one. This means that
:expand followed by :contract always returns the
original range.
:normalize FUNC Normalization function, optional. This function should
accept two unexpanded positions and adjust them before
expansion. May be used to deal with buffer boundaries.
:string FUNC Description function. This takes two buffer positions
and returns a human-readable string, for example,
\"2 lines\".
If further keywords and functions are specified, they are assumed to
be transformations on buffer positions, like :expand and :contract.
\(fn TYPE DOC [[KEY FUNC]...])"
(declare (indent defun)
(debug (&define name
[&optional stringp]
[&rest [keywordp function-form]])))
(let (args defun-forms func key name plist string sym val)
;; standard values
(setq plist (plist-put plist :one-to-one t))
;; keywords
(while (keywordp (car-safe body))
(setq key (pop body)
val (pop body))
(if (plist-member plist key) ; not a function
(setq plist (plist-put plist key val))
(setq func val
sym (intern (replace-regexp-in-string
"^:" "" (symbol-name key)))
name (intern (format "evil-%s-%s" type sym))
args (car (cdr-safe func))
string (car (cdr (cdr-safe func)))
string (if (stringp string)
(format "%s\n\n" string) "")
plist (plist-put plist key `',name))
(add-to-list
'defun-forms
(cond
((eq key :string)
`(defun ,name (beg end &rest properties)
,(format "Return size of %s from BEG to END \
with PROPERTIES.\n\n%s%s" type string doc)
(let ((beg (evil-normalize-position beg))
(end (evil-normalize-position end))
(type ',type)
plist range)
(when (and beg end)
(save-excursion
(evil-sort beg end)
(unless (plist-get properties :expanded)
(setq range (apply #'evil-expand
beg end type properties)
beg (evil-range-beginning range)
end (evil-range-end range)
type (evil-type range type)
plist (evil-range-properties range))
(setq properties
(evil-concat-plists properties plist)))
(or (apply #',func beg end
(when ,(> (length args) 2)
properties))
""))))))
(t
`(defun ,name (beg end &rest properties)
,(format "Perform %s transformation on %s from BEG to END \
with PROPERTIES.\n\n%s%s" sym type string doc)
(let ((beg (evil-normalize-position beg))
(end (evil-normalize-position end))
(type ',type)
plist range)
(when (and beg end)
(save-excursion
(evil-sort beg end)
(when (memq ,key '(:expand :contract))
(setq properties
(plist-put properties
:expanded
,(eq key :expand))))
(setq range (or (apply #',func beg end
(when ,(> (length args) 2)
properties))
(apply #'evil-range
beg end type properties))
beg (evil-range-beginning range)
end (evil-range-end range)
type (evil-type range type)
plist (evil-range-properties range))
(setq properties
(evil-concat-plists properties plist))
(apply #'evil-range beg end type properties)))))))
t)))
;; :one-to-one requires both or neither of :expand and :contract
(when (plist-get plist :expand)
(setq plist (plist-put plist :one-to-one
(and (plist-get plist :contract)
(plist-get plist :one-to-one)))))
`(progn
(evil-put-property 'evil-type-properties ',type ,@plist)
,@defun-forms
',type)))
(defmacro evil-define-interactive-code (code &rest body)
"Define an interactive code.
PROMPT, if given, is the remainder of the interactive string
up to the next newline. Command properties may be specified
via KEY-VALUE pairs. BODY should evaluate to a list of values.
\(fn CODE (PROMPT) [[KEY VALUE]...] BODY...)"
(declare (indent defun))
(let* ((args (when (and (> (length body) 1)
(listp (car-safe body)))
(pop body)))
(doc (when (stringp (car-safe body)) (pop body)))
func properties)
(while (keywordp (car-safe body))
(setq properties
(append properties (list (pop body) (pop body)))))
(cond
(args
(setq func `(lambda ,args
,@(when doc `(,doc))
,@body)))
((> (length body) 1)
(setq func `(progn ,@body)))
(t
(setq func (car body))))
`(eval-and-compile
(let* ((code ,code)
(entry (assoc code evil-interactive-alist))
(value (cons ',func ',properties)))
(if entry
(setcdr entry value)
(push (cons code value) evil-interactive-alist))
code))))
;;; Highlighting
(when (fboundp 'font-lock-add-keywords)
(font-lock-add-keywords
'emacs-lisp-mode
;; Match all `evil-define-' forms except `evil-define-key'.
;; (In the interests of speed, this expression is incomplete
;; and does not match all three-letter words.)
'(("(\\(evil-\\(?:ex-\\)?define-\
\\(?:[^ k][^ e][^ y]\\|[-[:word:]]\\{4,\\}\\)\\)\
\\>[ \f\t\n\r\v]*\\(\\(?:\\sw\\|\\s_\\)+\\)?"
(1 font-lock-keyword-face)
(2 font-lock-function-name-face nil t))
("(\\(evil-\\(?:delay\\|narrow\\|signal\\|save\\|with\\(?:out\\)?\\)\
\\(?:-[-[:word:]]+\\)?\\)\\>\[ \f\t\n\r\v]+"
1 font-lock-keyword-face)
("(\\(evil-\\(?:[-[:word:]]\\)*loop\\)\\>[ \f\t\n\r\v]+"
1 font-lock-keyword-face))))
(provide 'evil-macros)
;;; evil-macros.el ends here
