emenel/doomemacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Introduce letf! convenience macro

Browse source 
A more succinct cl-letf, which allows for local functions and macros.
This commit is contained in:
Henrik Lissner 2020-04-29 21:08:17 -04:00
parent c3a84f0fbf
commit d12752324a
No known key found for this signature in database
GPG key ID: 5F6C0EA160557395
12 changed files with 113 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

5
core/autoload/debug.el
View file

@ -46,10 +46,7 @@ ready to be pasted in a bug report on github."
(require 'core-packages)
(let ((default-directory doom-emacs-dir)
(doom-modules (doom-modules)))
(cl-letf
(((symbol-function 'sh)
(lambda (&rest args)
(cdr (apply #'doom-call-process args)))))
(letf! (defun sh (&rest args) (cdr (apply #'doom-call-process args)))
`((emacs
(version . ,emacs-version)
(features ,@system-configuration-features)

23
core/core-editor.el
View file

@ -293,10 +293,7 @@ possible."
`pp' can be expensive for longer lists, and there's no reason to prettify cache
files, so we replace calls to `pp' with the much faster `prin1'."
:around #'save-place-alist-to-file
(cl-letf (((symbol-function #'pp) #'prin1))
(funcall orig-fn)))
(save-place-mode +1))
(letf! ((#'pp #'prin1)) (funcall orig-fn))))
(use-package! server
@ -394,18 +391,14 @@ files, so we replace calls to `pp' with the much faster `prin1'."
`nim-mode'. This prevents them from leaving Emacs in a broken state."
:around #'dtrt-indent-mode
(let ((dtrt-indent-run-after-smie dtrt-indent-run-after-smie))
(cl-letf* ((old-smie-config-guess (symbol-function 'smie-config-guess))
(old-smie-config--guess (symbol-function 'symbol-config--guess))
((symbol-function 'symbol-config--guess)
(lambda (beg end)
(funcall old-smie-config--guess beg (min end 10000))))
((symbol-function 'smie-config-guess)
(lambda ()
(condition-case e (funcall old-smie-config-guess)
(letf! ((defun symbol-config--guess (beg end)
(funcall symbol-config--guess beg (min end 10000)))
(defun smie-config-guess ()
(condition-case e (funcall smie-config-guess)
(error (setq dtrt-indent-run-after-smie t)
(message "[WARNING] Indent detection: %s"
(error-message-string e))
(message "")))))) ; warn silently
(message ""))))) ; warn silently
(funcall orig-fn arg)))))
@ -421,8 +414,8 @@ files, so we replace calls to `pp' with the much faster `prin1'."
(defun doom-use-helpful-a (orig-fn &rest args)
"Force ORIG-FN to use helpful instead of the old describe-* commands."
(cl-letf (((symbol-function #'describe-function) #'helpful-function)
((symbol-function #'describe-variable) #'helpful-variable))
(letf! ((#'describe-function #'helpful-function)
(#'describe-variable #'helpful-variable))
(apply orig-fn args)))
(after! apropos

45
core/core-lib.el
View file

@ -191,6 +191,37 @@ aliases."
(setenv (car var) (cdr var)))
,@body))
(defmacro letf! (bindings &rest body)
"Temporarily rebind function and macros in BODY.
BINDINGS is either a) a list of, or a single, `defun' or `defmacro'-ish form, or
b) a list of (PLACE VALUE) bindings as `cl-letf*' would accept.
TYPE is either `defun' or `defmacro'. NAME is the name of the function. If an
original definition for NAME exists, it can be accessed as a lexical variable by
the same name, for use with `funcall' or `apply'. ARGLIST and BODY are as in
`defun'.
\(fn ((TYPE NAME ARGLIST &rest BODY) ...) BODY...)"
(declare (indent defun))
(setq body (macroexp-progn body))
(when (memq (car bindings) '(defun defmacro))
(setq bindings (list bindings)))
(dolist (binding (nreverse bindings) body)
(let ((type (car binding))
(rest (cdr binding)))
(setq
body (pcase type
(`defmacro `(cl-macrolet ((,(car rest) ,(cadr rest) ,@(cddr rest))) ,body))
(`defun `(cl-letf* ((,(car rest) (symbol-function #',(car rest)))
((symbol-function #',(car rest))
(lambda ,(cadr rest) ,@(cddr rest))))
,body))
(_
(when (eq (car-safe type) 'function)
(setq type `(symbol-function ,type)))
`(cl-letf ((,type ,@rest)) ,body)))))))
(defmacro quiet! (&rest forms)
"Run FORMS without generating any output.
@ -198,15 +229,13 @@ This silences calls to `message', `load-file', `write-region' and anything that
writes to `standard-output'."
`(cond (doom-debug-mode ,@forms)
((not doom-interactive-mode)
(let ((old-fn (symbol-function 'write-region)))
(cl-letf ((standard-output (lambda (&rest _)))
((symbol-function 'load-file) (lambda (file) (load file nil t)))
((symbol-function 'message) (lambda (&rest _)))
((symbol-function 'write-region)
(lambda (start end filename &optional append visit lockname mustbenew)
(letf! ((standard-output (lambda (&rest _)))
(defun load-file (file) (load-file nil t))
(defun message (&rest _))
(defun write-region (start end filename &optional append visit lockname mustbenew)
(unless visit (setq visit 'no-message))
(funcall old-fn start end filename append visit lockname mustbenew))))
,@forms)))
(funcall write-region start end filename append visit lockname mustbenew)))
,@forms))
((let ((inhibit-message t)
(save-silently t))
(prog1 ,@forms (message ""))))))

6
core/core-ui.el
View file

@ -619,10 +619,8 @@ This offers a moderate boost in startup (or theme switch) time, so long as
:around #'load-theme
(if (or (null after-init-time)
doom--prefer-theme-elc)
(cl-letf* ((old-locate-file (symbol-function 'locate-file))
((symbol-function 'locate-file)
(lambda (filename path &optional _suffixes predicate)
(funcall old-locate-file filename path '("c" "") predicate))))
(letf! (defun locate-file (filename path &optional _suffixes predicate)
(funcall locate-file filename path '("c" "") predicate))
(apply orig-fn args))
(apply orig-fn args))))

5
modules/app/rss/autoload.el
View file

@ -101,10 +101,9 @@
;;;###autoload
(defun +rss-put-sliced-image-fn (spec alt &optional flags)
"TODO"
(cl-letf (((symbol-function #'insert-image)
(lambda (image &optional alt _area _slice)
(letf! (defun insert-image (image &optional alt _area _slice)
(let ((height (cdr (image-size image t))))
(insert-sliced-image image alt nil (max 1 (/ height 20.0)) 1)))))
(insert-sliced-image image alt nil (max 1 (/ height 20.0)) 1)))
(shr-put-image spec alt flags)))
;;;###autoload

6
modules/editor/evil/autoload/advice.el
View file

@ -123,8 +123,7 @@ more information on modifiers."
(not (eq this-command 'evil-open-below))
(evil-insert-state-p))
(funcall orig-fn count)
(cl-letf (((symbol-function 'evil-insert-newline-below)
(lambda () (+evil--insert-newline))))
(letf! (defun evil-insert-newline-below () (+evil--insert-newline))
(let ((evil-auto-indent evil-auto-indent))
(funcall orig-fn count)))))
@ -134,8 +133,7 @@ more information on modifiers."
(not (eq this-command 'evil-open-above))
(evil-insert-state-p))
(funcall orig-fn count)
(cl-letf (((symbol-function 'evil-insert-newline-above)
(lambda () (+evil--insert-newline 'above))))
(letf! (defun evil-insert-newline-above () (+evil--insert-newline 'above))
(let ((evil-auto-indent evil-auto-indent))
(funcall orig-fn count)))))

2
modules/editor/snippets/config.el
View file

@ -102,6 +102,6 @@
us who use yas-minor-mode and enable yasnippet more selectively. This advice
swaps `yas-global-mode' with `yas-minor-mode'."
:around '(aya-expand aya-open-line)
(cl-letf (((symbol-function #'yas-global-mode) #'yas-minor-mode)
(letf! ((#'yas-global-mode #'yas-minor-mode)
(yas-global-mode yas-minor-mode))
(apply orig-fn args))))

2
modules/lang/org/autoload/org-capture.el
View file

@ -50,7 +50,7 @@ you're done. This can be called from an external shell script."
(with-selected-frame frame
(require 'org-capture)
(condition-case ex
(cl-letf (((symbol-function #'pop-to-buffer) #'switch-to-buffer))
(letf! ((#'pop-to-buffer #'switch-to-buffer))
(switch-to-buffer (doom-fallback-buffer))
(let ((org-capture-initial initial-input)
org-capture-entry)

6
modules/lang/org/config.el
View file

@ -539,11 +539,9 @@ current workspace (and clean them up)."
;; upstream (if ever).
(defadvice! +org--fix-inline-images-for-imagemagick-users-a (orig-fn &rest args)
:around #'org-display-inline-images
(cl-letf* ((old-create-image (symbol-function #'create-image))
((symbol-function #'create-image)
(lambda (file-or-data &optional type data-p &rest props)
(letf! (defun create-image (file-or-data &optional type data-p &rest props)
(let ((type (if (plist-get props :width) type)))
(apply old-create-image file-or-data type data-p props)))))
(apply create-image file-or-data type data-p props)))
(apply orig-fn args)))
(defadvice! +org--fix-inconsistent-uuidgen-case-a (uuid)

5
modules/lang/org/contrib/present.el
View file

@ -41,8 +41,7 @@
(defadvice! +org-present--narrow-to-subtree-a (orig-fn &rest args)
"Narrow to the target subtree when you start the presentation."
:around #'org-tree-slide--display-tree-with-narrow
(cl-letf (((symbol-function #'org-narrow-to-subtree)
(lambda ()
(letf! ((defun org-narrow-to-subtree ()
(save-excursion
(save-match-data
(org-with-limited-levels
@ -56,5 +55,5 @@
(progn (org-end-of-subtree t t)
(when (and (org-at-heading-p) (not (eobp)))
(backward-char 1))
(point)))))))))
(point))))))))
(apply orig-fn args))))

8
modules/tools/pdf/config.el
View file

@ -33,12 +33,10 @@
:around '(pdf-annot-show-annotation
pdf-isearch-hl-matches
pdf-view-display-region)
(cl-letf* ((old-create-image (symbol-function #'create-image))
((symbol-function #'create-image)
(lambda (file-or-data &optional type data-p &rest props)
(apply old-create-image file-or-data type data-p
(letf! (defun create-image (file-or-data &optional type data-p &rest props)
(apply create-image file-or-data type data-p
:width (car (pdf-view-image-size))
props))))
props))
(apply orig-fn args))))
;; Handle PDF-tools related popups better

49
modules/ui/popup/+hacks.el
View file

@ -195,20 +195,18 @@ the command buffer."
;; Fix #897: "cannot open side window" error when TAB-completing file links
(defadvice! +popup--helm-hide-org-links-popup-a (orig-fn &rest args)
:around #'org-insert-link
(cl-letf* ((old-org-completing-read (symbol-function 'org-completing-read))
((symbol-function 'org-completing-read)
(lambda (&rest args)
(letf! ((defun org-completing-read (&rest args)
(when-let (win (get-buffer-window "*Org Links*"))
;; While helm is opened as a popup, it will mistaken the
;; *Org Links* popup for the "originated window", and will
;; target it for actions invoked by the user. However, since
;; *Org Links* is a popup too (they're dedicated side
;; windows), Emacs complains about being unable to split a
;; side window. The simple fix: get rid of *Org Links*!
;; While helm is opened as a popup, it will mistaken the *Org
;; Links* popup for the "originated window", and will target it
;; for actions invoked by the user. However, since *Org Links*
;; is a popup too (they're dedicated side windows), Emacs
;; complains about being unable to split a side window. The
;; simple fix: get rid of *Org Links*!
(delete-window win)
;; But it must exist for org to clean up later.
;; ...but it must exist for org to clean up later.
(get-buffer-create "*Org Links*"))
(apply old-org-completing-read args))))
(apply org-completing-read args)))
(apply #'funcall-interactively orig-fn args)))
;; Fix left-over popup window when closing persistent help for `helm-M-x'
@ -228,7 +226,6 @@ the command buffer."
(when (+popup-window-p win)
(select-window win))))
;;;###package org
(after! org
;; Org has a scorched-earth window management policy I'm not fond of. i.e. it
@ -242,10 +239,8 @@ the command buffer."
org-fast-tag-selection
org-fast-todo-selection)
(if +popup-mode
(cl-letf (((symbol-function #'delete-other-windows)
(symbol-function #'ignore))
((symbol-function #'delete-window)
(symbol-function #'ignore)))
(letf! ((#'delete-other-windows #'ignore)
(#'delete-window #'ignore))
(apply orig-fn args))
(apply orig-fn args)))
@ -256,16 +251,14 @@ Ugh, such an ugly hack."
:around '(org-fast-tag-selection
org-fast-todo-selection)
(if +popup-mode
(cl-letf* ((old-fit-buffer-fn (symbol-function #'org-fit-window-to-buffer))
((symbol-function #'org-fit-window-to-buffer)
(lambda (&optional window max-height min-height shrink-only)
(letf! ((defun org-fit-window-to-buffer (&optional window max-height min-height shrink-only)
(when-let (buf (window-buffer window))
(delete-window window)
(select-window
(setq window (display-buffer-at-bottom buf nil)))
(with-current-buffer buf
(setq mode-line-format nil)))
(funcall old-fit-buffer-fn window max-height min-height shrink-only))))
(funcall org-fit-window-to-buffer window max-height min-height shrink-only)))
(apply orig-fn args))
(apply orig-fn args)))
@ -284,8 +277,7 @@ Ugh, such an ugly hack."
;; _then_ hand off the buffer to the pop up manager.
(defadvice! +popup--org-src-switch-to-buffer-a (orig-fn &rest args)
:around #'org-src-switch-to-buffer
(cl-letf (((symbol-function #'pop-to-buffer-same-window)
(symbol-function #'switch-to-buffer)))
(letf! ((#'pop-to-buffer-same-window #'switch-to-buffer))
(apply orig-fn args))))
@ -316,8 +308,7 @@ Ugh, such an ugly hack."
;;;###package profiler
(defadvice! +popup--profiler-report-find-entry-in-other-window-a (orig-fn function)
:around #'profiler-report-find-entry
(cl-letf (((symbol-function 'find-function)
(symbol-function 'find-function-other-window)))
(letf! ((#'find-function #'find-function-other-window))
(funcall orig-fn function)))
@ -337,10 +328,9 @@ Ugh, such an ugly hack."
which-key-custom-hide-popup-function #'which-key--hide-buffer-side-window
which-key-custom-show-popup-function
(lambda (act-popup-dim)
(cl-letf (((symbol-function 'display-buffer-in-side-window)
(lambda (buffer alist)
(letf! ((defun display-buffer-in-side-window (buffer alist)
(+popup-display-buffer-stacked-side-window-fn
buffer (append '((vslot . -9999)) alist)))))
buffer (append '((vslot . -9999)) alist))))
;; HACK Fix #2219 where the which-key popup would get cut off.
(setcar act-popup-dim (1+ (car act-popup-dim)))
(which-key--show-buffer-side-window act-popup-dim))))))
@ -351,9 +341,8 @@ Ugh, such an ugly hack."
(defadvice! +popup--ignore-window-parameters-a (orig-fn &rest args)
"Allow *interactive* window moving commands to traverse popups."
:around '(windmove-up windmove-down windmove-left windmove-right)
(cl-letf (((symbol-function #'windmove-find-other-window)
(lambda (dir &optional arg window)
(letf! ((defun windmove-find-other-window (dir &optional arg window)
(window-in-direction
(pcase dir (`up 'above) (`down 'below) (_ dir))
window (bound-and-true-p +popup-mode) arg windmove-wrap-around t))))
window (bound-and-true-p +popup-mode) arg windmove-wrap-around t)))
(apply orig-fn args)))