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) (require 'core-packages)
(let ((default-directory doom-emacs-dir) (let ((default-directory doom-emacs-dir)
(doom-modules (doom-modules))) (doom-modules (doom-modules)))
(cl-letf (letf! (defun sh (&rest args) (cdr (apply #'doom-call-process args)))
(((symbol-function 'sh)
(lambda (&rest args)
(cdr (apply #'doom-call-process args)))))
`((emacs `((emacs
(version . ,emacs-version) (version . ,emacs-version)
(features ,@system-configuration-features) (features ,@system-configuration-features)

29
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 `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'." files, so we replace calls to `pp' with the much faster `prin1'."
:around #'save-place-alist-to-file :around #'save-place-alist-to-file
(cl-letf (((symbol-function #'pp) #'prin1)) (letf! ((#'pp #'prin1)) (funcall orig-fn))))
(funcall orig-fn)))
(save-place-mode +1))
(use-package! server (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." `nim-mode'. This prevents them from leaving Emacs in a broken state."
:around #'dtrt-indent-mode :around #'dtrt-indent-mode
(let ((dtrt-indent-run-after-smie dtrt-indent-run-after-smie)) (let ((dtrt-indent-run-after-smie dtrt-indent-run-after-smie))
(cl-letf* ((old-smie-config-guess (symbol-function 'smie-config-guess)) (letf! ((defun symbol-config--guess (beg end)
(old-smie-config--guess (symbol-function 'symbol-config--guess)) (funcall symbol-config--guess beg (min end 10000)))
((symbol-function 'symbol-config--guess) (defun smie-config-guess ()
(lambda (beg end) (condition-case e (funcall smie-config-guess)
(funcall old-smie-config--guess beg (min end 10000)))) (error (setq dtrt-indent-run-after-smie t)
((symbol-function 'smie-config-guess) (message "[WARNING] Indent detection: %s"
(lambda () (error-message-string e))
(condition-case e (funcall old-smie-config-guess) (message ""))))) ; warn silently
(error (setq dtrt-indent-run-after-smie t)
(message "[WARNING] Indent detection: %s"
(error-message-string e))
(message "")))))) ; warn silently
(funcall orig-fn arg))))) (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) (defun doom-use-helpful-a (orig-fn &rest args)
"Force ORIG-FN to use helpful instead of the old describe-* commands." "Force ORIG-FN to use helpful instead of the old describe-* commands."
(cl-letf (((symbol-function #'describe-function) #'helpful-function) (letf! ((#'describe-function #'helpful-function)
((symbol-function #'describe-variable) #'helpful-variable)) (#'describe-variable #'helpful-variable))
(apply orig-fn args))) (apply orig-fn args)))
(after! apropos (after! apropos

47
core/core-lib.el
View file

@ -191,6 +191,37 @@ aliases."
(setenv (car var) (cdr var))) (setenv (car var) (cdr var)))
,@body)) ,@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) (defmacro quiet! (&rest forms)
"Run FORMS without generating any output. "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'." writes to `standard-output'."
`(cond (doom-debug-mode ,@forms) `(cond (doom-debug-mode ,@forms)
((not doom-interactive-mode) ((not doom-interactive-mode)
(let ((old-fn (symbol-function 'write-region))) (letf! ((standard-output (lambda (&rest _)))
(cl-letf ((standard-output (lambda (&rest _))) (defun load-file (file) (load-file nil t))
((symbol-function 'load-file) (lambda (file) (load file nil t))) (defun message (&rest _))
((symbol-function 'message) (lambda (&rest _))) (defun write-region (start end filename &optional append visit lockname mustbenew)
((symbol-function 'write-region) (unless visit (setq visit 'no-message))
(lambda (start end filename &optional append visit lockname mustbenew) (funcall write-region start end filename append visit lockname mustbenew)))
(unless visit (setq visit 'no-message)) ,@forms))
(funcall old-fn start end filename append visit lockname mustbenew))))
,@forms)))
((let ((inhibit-message t) ((let ((inhibit-message t)
(save-silently t)) (save-silently t))
(prog1 ,@forms (message "")))))) (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 :around #'load-theme
(if (or (null after-init-time) (if (or (null after-init-time)
doom--prefer-theme-elc) doom--prefer-theme-elc)
(cl-letf* ((old-locate-file (symbol-function 'locate-file)) (letf! (defun locate-file (filename path &optional _suffixes predicate)
((symbol-function 'locate-file) (funcall locate-file filename path '("c" "") predicate))
(lambda (filename path &optional _suffixes predicate)
(funcall old-locate-file filename path '("c" "") predicate))))
(apply orig-fn args)) (apply orig-fn args))
(apply orig-fn args)))) (apply orig-fn args))))

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

@ -101,10 +101,9 @@
;;;###autoload ;;;###autoload
(defun +rss-put-sliced-image-fn (spec alt &optional flags) (defun +rss-put-sliced-image-fn (spec alt &optional flags)
"TODO" "TODO"
(cl-letf (((symbol-function #'insert-image) (letf! (defun insert-image (image &optional alt _area _slice)
(lambda (image &optional alt _area _slice) (let ((height (cdr (image-size image t))))
(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))) (shr-put-image spec alt flags)))
;;;###autoload ;;;###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)) (not (eq this-command 'evil-open-below))
(evil-insert-state-p)) (evil-insert-state-p))
(funcall orig-fn count) (funcall orig-fn count)
(cl-letf (((symbol-function 'evil-insert-newline-below) (letf! (defun evil-insert-newline-below () (+evil--insert-newline))
(lambda () (+evil--insert-newline))))
(let ((evil-auto-indent evil-auto-indent)) (let ((evil-auto-indent evil-auto-indent))
(funcall orig-fn count))))) (funcall orig-fn count)))))
@ -134,8 +133,7 @@ more information on modifiers."
(not (eq this-command 'evil-open-above)) (not (eq this-command 'evil-open-above))
(evil-insert-state-p)) (evil-insert-state-p))
(funcall orig-fn count) (funcall orig-fn count)
(cl-letf (((symbol-function 'evil-insert-newline-above) (letf! (defun evil-insert-newline-above () (+evil--insert-newline 'above))
(lambda () (+evil--insert-newline 'above))))
(let ((evil-auto-indent evil-auto-indent)) (let ((evil-auto-indent evil-auto-indent))
(funcall orig-fn count))))) (funcall orig-fn count)))))

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

@ -102,6 +102,6 @@
us who use yas-minor-mode and enable yasnippet more selectively. This advice us who use yas-minor-mode and enable yasnippet more selectively. This advice
swaps `yas-global-mode' with `yas-minor-mode'." swaps `yas-global-mode' with `yas-minor-mode'."
:around '(aya-expand aya-open-line) :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)) (yas-global-mode yas-minor-mode))
(apply orig-fn args)))) (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 (with-selected-frame frame
(require 'org-capture) (require 'org-capture)
(condition-case ex (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)) (switch-to-buffer (doom-fallback-buffer))
(let ((org-capture-initial initial-input) (let ((org-capture-initial initial-input)
org-capture-entry) org-capture-entry)

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

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

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

@ -41,20 +41,19 @@
(defadvice! +org-present--narrow-to-subtree-a (orig-fn &rest args) (defadvice! +org-present--narrow-to-subtree-a (orig-fn &rest args)
"Narrow to the target subtree when you start the presentation." "Narrow to the target subtree when you start the presentation."
:around #'org-tree-slide--display-tree-with-narrow :around #'org-tree-slide--display-tree-with-narrow
(cl-letf (((symbol-function #'org-narrow-to-subtree) (letf! ((defun org-narrow-to-subtree ()
(lambda () (save-excursion
(save-excursion (save-match-data
(save-match-data (org-with-limited-levels
(org-with-limited-levels (narrow-to-region
(narrow-to-region (progn
(progn (when (org-before-first-heading-p)
(when (org-before-first-heading-p) (org-next-visible-heading 1))
(org-next-visible-heading 1)) (ignore-errors (org-up-heading-all 99))
(ignore-errors (org-up-heading-all 99)) (forward-line 1)
(forward-line 1) (point))
(point)) (progn (org-end-of-subtree t t)
(progn (org-end-of-subtree t t) (when (and (org-at-heading-p) (not (eobp)))
(when (and (org-at-heading-p) (not (eobp))) (backward-char 1))
(backward-char 1)) (point))))))))
(point)))))))))
(apply orig-fn args)))) (apply orig-fn args))))

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

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

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