Download
(eval-when-compile (require 'cl))
(require 'highlight)
(defgroup eval-sexp-fu nil
"Tiny functionality enhancements for evaluating sexps."
:prefix "eval-sexp-fu-"
:group 'eval-sexp-fu)
(defface eval-sexp-fu-flash
'((((class color)) (:background "blue" :foreground "white" :bold t))
(t (:inverse-video t)))
"Face for highlighting sexps during evaluation."
:group 'eval-sexp-fu)
(defface eval-sexp-fu-flash-error
'((((class color)) (:foreground "red" :bold t))
(t (:inverse-video t)))
"Face for highlighting sexps signaled errors during evaluation."
:group 'eval-sexp-fu)
(defcustom eval-sexp-fu-flash-face 'eval-sexp-fu-flash
"*Face to use for showing the sexps' overlay during the evaluation."
:type 'face
:group 'eval-sexp-fu)
(defcustom eval-sexp-fu-flash-error-face 'eval-sexp-fu-flash-error
"*Face to use for showing the sexps' overlay if the evaluation signaled any error. The error highlighting is take into account only if non-nil value."
:type 'face
:group 'eval-sexp-fu)
(defcustom eval-sexp-fu-flash-duration 0.15
"*For time duration, highlight the evaluating sexps."
:type 'number
:group 'eval-sexp-fu)
(defcustom eval-sexp-fu-flash-error-duration 0.3
"*For time duration, highlight the evaluating sexps signaled errors."
:type 'number
:group 'eval-sexp-fu)
(defcustom eval-sexp-fu-flash-function 'eval-sexp-fu-flash-default
"*Function to be used to create all of the actual flashing implementations."
:type '(choice (function-item eval-sexp-fu-flash-default)
(function-item eval-sexp-fu-flash-paren-only))
:group 'eval-sexp-fu)
(defmacro esf-konstantly (v)
`(lambda (&rest _it) ,v))
(defun esf-every0 (pred xs)
(labels ((rec (pred xs acc)
(if (null xs)
acc
(let ((it (funcall pred (car xs))))
(and it (rec pred (cdr xs) it))))))
(rec pred xs nil)))
(defun esf-every-pred (&rest preds)
(lexical-let ((preds preds))
(lambda (x)
(esf-every0 (lambda (pred) (funcall pred x))
preds))))
(defun esf-hl-highlight-bounds (bounds face buf)
(with-current-buffer buf
(hlt-highlight-region (car bounds) (cdr bounds) face)))
(defun esf-hl-unhighlight-bounds (bounds buf)
(with-current-buffer buf
(hlt-unhighlight-region (car bounds) (cdr bounds))))
(defun esf-flash-error-bounds (bounds buf face)
(when face
(let ((flash-error
(lambda (bounds buf face)
(esf-hl-highlight-bounds bounds face buf)
(run-at-time eval-sexp-fu-flash-error-duration nil
'esf-hl-unhighlight-bounds
bounds buf))))
(run-with-idle-timer (max eval-sexp-fu-flash-error-duration
eval-sexp-fu-flash-duration)
nil flash-error
bounds buf face))))
(defun* eval-sexp-fu-flash (bounds &optional (face eval-sexp-fu-flash-face) (eface eval-sexp-fu-flash-error-face))
"BOUNS is either the cell or the function returns, such that (BEGIN . END).
Reurn the 4 values; bounds, highlighting, un-highlighting and error flashing procedure. This function is convenient to use with `define-eval-sexp-fu-flash-command'."
(flet ((bounds () (if (functionp bounds) (funcall bounds) bounds)))
(let ((b (bounds)))
(when b
(funcall eval-sexp-fu-flash-function b face eface (current-buffer))))))
(defun eval-sexp-fu-flash-default (bounds face eface buf)
"Create all of the actual flashing implementations. See also `eval-sexp-fu-flash'."
(values bounds
(apply-partially 'esf-hl-highlight-bounds bounds face buf)
(apply-partially 'esf-hl-unhighlight-bounds bounds buf)
(apply-partially 'esf-flash-error-bounds bounds buf eface)))
(defun eval-sexp-fu-flash-paren-only (bounds face eface buf)
(esf-flash-paren-only-if (esf-every-pred
'esf-flash-paren-surrounded-p
'esf-flash-paren-visible-p)
bounds face eface buf))
(defun esf-flash-paren-only-if (pred bounds face eface buf)
(let ((flash (if (funcall pred (cons bounds buf))
'esf-flash-paren-only
'eval-sexp-fu-flash-default)))
(funcall flash bounds face eface buf)))
(defun esf-flash-paren-only (bounds face eface buf)
"Create the \"paren-only\" flashing implementations."
(let ((hi (lambda (left right face buf)
(esf-hl-highlight-bounds left face buf)
(esf-hl-highlight-bounds right face buf)))
(uh (lambda (left right buf)
(esf-hl-unhighlight-bounds left buf)
(esf-hl-unhighlight-bounds right buf)))
(ef (lambda (left right eface buf)
(esf-flash-error-bounds left buf eface)
(esf-flash-error-bounds right buf eface)))
(rparen (cons (1- (cdr bounds)) (cdr bounds)))
(lparen (cons (car bounds) (save-excursion
(goto-char (car bounds))
(down-list)
(point)))))
(values bounds
(apply-partially hi lparen rparen face buf)
(apply-partially uh lparen rparen buf)
(apply-partially ef lparen rparen eface buf))))
(defun* esf-flash-paren-surrounded-p ((bounds . buf))
(with-current-buffer buf
(and (save-excursion
(goto-char (1- (cdr bounds)))
(looking-at (rx (syntax close-parenthesis))))
(save-excursion
(goto-char (car bounds))
(looking-at (rx (or (syntax expression-prefix)
(syntax open-parenthesis))))))))
(defun* esf-flash-paren-visible-p ((bounds . _buf))
(and (pos-visible-in-window-p (cdr bounds))
(pos-visible-in-window-p (car bounds))))
(defcustom eval-sexp-fu-flash-doit-function 'eval-sexp-fu-flash-doit-simple
"*Function to use for flashing the sexps.
Please see the actual implementations:
- `eval-sexp-fu-flash-doit-simple'
- `eval-sexp-fu-flash-doit-hold-on-error'"
:type 'function
:group 'eval-sexp-fu)
(defun eval-sexp-fu-flash-doit (do-it-thunk hi unhi)
(funcall eval-sexp-fu-flash-doit-function do-it-thunk hi unhi))
(defun eval-sexp-fu-flash-doit-simple (do-it-thunk hi unhi)
(funcall hi)
(run-at-time eval-sexp-fu-flash-duration nil unhi)
(funcall do-it-thunk))
(defun eval-sexp-fu-flash-doit-hold-on-error (do-it-thunk hi unhi)
(funcall hi)
(unwind-protect
(funcall do-it-thunk)
(run-at-time eval-sexp-fu-flash-duration nil unhi)))
(defmacro esf-unwind-protect-with-tracking (normallyp body unwind)
(declare (indent 2))
`(let (,normallyp)
(unwind-protect
(prog1 ,body
(setq ,normallyp t))
,unwind)))
(defun esf-flash-doit (do-it-thunk hi unhi eflash)
(esf-unwind-protect-with-tracking ret
(eval-sexp-fu-flash-doit do-it-thunk hi unhi)
(unless ret
(funcall eflash))))
(defmacro define-eval-sexp-fu-flash-command (command form)
"Install the flasher implemented as the COMMAND's around advice.
FORM is expected to return 4 values;
- A bounds (BEGIN . END) to be highlighted or nil.
- An actual highlighting procedure takes 0 arguments.
- An actual un-highliting procedure takes 0 arguments.
- An actual flashing error procedure takes 0 arguments.
See also `eval-sexp-fu-flash'."
(declare (indent 1))
`(defadvice ,command (around eval-sexp-fu-flash-region activate)
(if eval-sexp-fu-flash-mode
(multiple-value-bind (bounds hi unhi eflash) ,form
(if bounds
(esf-flash-doit (esf-konstantly ad-do-it) hi unhi eflash)
ad-do-it))
ad-do-it)))
(define-minor-mode eval-sexp-fu-flash-mode
"Toggle EvalSexpFuFlash mode on or off. If this mode is on, some `eval-last-sexp'-ish commands will highlight the sexps during evaluation."
:init-value t :global t)
(defun turn-on-eval-sexp-fu-flash-mode ()
"Unequivocally turn on EvalSexpFuFlash mode
(see also `eval-sexp-fu-flash-mode')."
(interactive)
(eval-sexp-fu-flash-mode 1))
(defun esf-funcall-and-eval-last-sexp (before eval-last-sexp)
"Call 0 arg procedure BEFORE then call interactive command EVAL-LAST-SEXP."
(save-excursion
(funcall before)
(call-interactively eval-last-sexp)))
(require 'rx)
(defun esf-forward-inner-sexp0 ()
(flet ((poss ()
(let
((prev (save-excursion (backward-sexp) (forward-sexp) (point)))
(next (save-excursion (forward-sexp) (backward-sexp) (point))))
(list prev (line-number-at-pos prev)
next (line-number-at-pos next)
(point) (line-number-at-pos)))))
(cond ((looking-at (rx (or (syntax symbol) (syntax word)
(syntax open-parenthesis))))
(forward-sexp))
(t (destructuring-bind (pp pl np nl cp cl) (poss)
(cond ((and (<= pp cp) (<= cp np))
(cond ((= pl cl) (backward-sexp))
((= nl cl))
((< (- cl pl) (- nl cl)) (backward-sexp))
((< (- nl cl) (- cl pl)))
(t (backward-sexp)))
(forward-sexp))
(t (backward-sexp) (forward-sexp))))))))
(defun esf-forward-inner-sexp ()
(condition-case nil
(esf-forward-inner-sexp0)
(scan-error nil)))
(defun esf-backward-up-inner-list0 (steps)
(unless steps (setq steps 1))
(when (looking-at (rx (syntax open-parenthesis))) (decf steps))
(dotimes (_ steps) (backward-up-list)))
(defun esf-backward-up-inner-list (steps)
(condition-case nil
(esf-backward-up-inner-list0 steps)
(scan-error nil)))
(defun esf-end-of-backward-up-inner-list (steps)
(esf-backward-up-inner-list steps)
(esf-forward-inner-sexp))
(defun eval-sexp-fu-eval-sexp-inner-list (&optional arg)
"Evaluate the list _currently_ pointed at as sexp; print value in minibuffer.
Interactivelly with numeric prefix argument, call to `backward-up-list' happens several times. This function is an \"Evaluate this N lists, please.\" thing."
(interactive "P")
(esf-funcall-and-eval-last-sexp (apply-partially
'esf-end-of-backward-up-inner-list arg)
'esf-eval-last-sexp))
(defun eval-sexp-fu-eval-sexp-inner-sexp ()
"Evaluate the sexp _currently_ pointed; print value in minibuffer."
(interactive)
(esf-funcall-and-eval-last-sexp 'esf-forward-inner-sexp 'esf-eval-last-sexp))
(defmacro define-esf-eval-last-sexp-1 (command-name eval-last-sexp)
"Define an interactive command COMMAND-NAME kind of EVAL-LAST-SEXP
such that ignores any prefix arguments."
`(defun ,command-name ()
(interactive)
(let (current-prefix-arg)
(call-interactively ',eval-last-sexp))))
(define-esf-eval-last-sexp-1 esf-eval-last-sexp eval-last-sexp)
(defmacro define-esf-eval-sexp* (eval-last-sexp inner-sexp inner-list)
"Based on EVAL-LAST-SEXP, define INNER-SEXP and INNER-LIST interactive commands."
(declare (indent 1))
`(progn
(defun ,inner-sexp ()
(interactive)
(esf-funcall-and-eval-last-sexp 'esf-forward-inner-sexp
',eval-last-sexp))
(defun ,inner-list (&optional arg)
(interactive "P")
(esf-funcall-and-eval-last-sexp (apply-partially
'esf-end-of-backward-up-inner-list arg)
',eval-last-sexp))))
(defmacro define-eval-sexp-fu-eval-sexp (command-name-prefix eval-last-sexp)
"Define -inner-sexp and -inner-list interactive commands prefixed by COMMAND-NAME-PREFIX based on EVAL-LAST-SEXP. Actual work is done by `define-esf-eval-sexp*'."
(let ((esf-eval-last-sexp-1
(intern (format "esf-%s-1" (symbol-name eval-last-sexp)))))
`(progn
(define-esf-eval-last-sexp-1 ,esf-eval-last-sexp-1 ,eval-last-sexp)
(define-esf-eval-sexp* ,esf-eval-last-sexp-1
,@(mapcar (lambda (post)
(intern (concat (symbol-name command-name-prefix) post)))
'("-inner-sexp" "-inner-list"))))))
(if (version< "24.3.50" emacs-version)
(defmacro with-esf-end-of-sexp (&rest body)
(declare (indent 0))
`(progn ,@body))
(defmacro with-esf-end-of-sexp (&rest body)
(declare (indent 0))
`(save-excursion
(backward-char)
,@body)))
(defun esf-initialize ()
(define-eval-sexp-fu-flash-command eval-last-sexp
(eval-sexp-fu-flash (when (ignore-errors (preceding-sexp))
(with-esf-end-of-sexp
(bounds-of-thing-at-point 'sexp)))))
(define-eval-sexp-fu-flash-command eval-defun
(eval-sexp-fu-flash (when (ignore-errors (preceding-sexp))
(save-excursion
(end-of-defun)
(beginning-of-defun)
(bounds-of-thing-at-point 'sexp)))))
(eval-after-load 'eev
'(progn
(define-eval-sexp-fu-flash-command eek-eval-last-sexp
(eval-sexp-fu-flash (when (thing-at-point 'sexp)
(cons (save-excursion (eek-backward-sexp))
(point))))))))
(defun esf-initialize-slime ()
(define-eval-sexp-fu-flash-command slime-eval-last-expression
(eval-sexp-fu-flash (with-esf-end-of-sexp
(when (slime-sexp-at-point)
(bounds-of-thing-at-point 'sexp)))))
(define-eval-sexp-fu-flash-command slime-pprint-eval-last-expression
(eval-sexp-fu-flash (with-esf-end-of-sexp
(when (slime-sexp-at-point)
(bounds-of-thing-at-point 'sexp)))))
(define-eval-sexp-fu-flash-command slime-eval-defun
(eval-sexp-fu-flash (save-excursion
(slime-end-of-defun)
(slime-beginning-of-defun)
(when (slime-sexp-at-point)
(bounds-of-thing-at-point 'sexp)))))
(progn
(define-eval-sexp-fu-eval-sexp eval-sexp-fu-slime-eval-expression
slime-eval-last-expression)
(define-eval-sexp-fu-eval-sexp eval-sexp-fu-slime-pprint-eval-expression
slime-pprint-eval-last-expression)))
(eval-when (load eval)
(esf-initialize)
(eval-after-load 'slime
'(esf-initialize-slime)))
(dont-compile
(when (fboundp 'expectations)
(expectations
(desc "esf-every-pred")
(expect "value"
(funcall (esf-every-pred 'stringp 'identity)
"value"))
(expect t
(not (funcall (every-pred 'stringp 'numberp 'identity)
"value")))
(desc "esf-forward-inner-sexp0")
(expect ?p
(with-temp-buffer
(emacs-lisp-mode)
(insert "s+exp")
(goto-char (point-min))
(esf-forward-inner-sexp0)
(char-before)))
(expect ?p
(with-temp-buffer
(emacs-lisp-mode)
(insert "s+exp")
(goto-char (1+ (point-min)))
(esf-forward-inner-sexp0)
(char-before)))
(expect ?\)
(with-temp-buffer
(emacs-lisp-mode)
(insert "s(exp)")
(goto-char (1+ (point-min)))
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 same line, but far near the next")
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0 sexp1")
(goto-char (+ (point-min) 7))
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 across lines")
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(esf-forward-inner-sexp0)
(char-before)))
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(forward-line)
(esf-forward-inner-sexp0)
(char-before)))
(expect ?1
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(forward-line 3)
(esf-forward-inner-sexp0)
(char-before)))
(expect ?1
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(forward-line 3)
(esf-forward-inner-sexp0)
(char-before)))
(expect ?1
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(forward-line 4)
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 across lines (equal delta)")
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n\n\nsexp1")
(goto-char (point-min))
(forward-line 2)
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 no more")
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "sexp0\n\n")
(goto-char (point-max))
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 no less")
(expect ?0
(with-temp-buffer
(emacs-lisp-mode)
(insert "\n\nsexp0")
(goto-char (point-min))
(esf-forward-inner-sexp0)
(char-before)))
(desc "esf-forward-inner-sexp0 no any")
(expect 5
(with-temp-buffer
(emacs-lisp-mode)
(insert "\n\n\n\n")
(goto-char (point-min))
(esf-forward-inner-sexp0)
(point)))
)))
(provide 'eval-sexp-fu)