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

7
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)
(let ((height (cdr (image-size image t))))
(insert-sliced-image image alt nil (max 1 (/ height 20.0)) 1)))))
(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)))
(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)))))

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
swaps `yas-global-mode' with `yas-minor-mode'."
:around '(aya-expand aya-open-line)
(cl-letf (((symbol-function #'yas-global-mode) #'yas-minor-mode)
(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)

8
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)
(let ((type (if (plist-get props :width) type)))
(apply old-create-image file-or-data type data-p props)))))
(letf! (defun create-image (file-or-data &optional type data-p &rest props)
(let ((type (if (plist-get props :width) type)))
(apply create-image file-or-data type data-p props)))
(apply orig-fn args)))
(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)
"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 ()
(save-excursion
(save-match-data
(org-with-limited-levels
(narrow-to-region
(progn
(when (org-before-first-heading-p)
(org-next-visible-heading 1))
(ignore-errors (org-up-heading-all 99))
(forward-line 1)
(point))
(progn (org-end-of-subtree t t)
(when (and (org-at-heading-p) (not (eobp)))
(backward-char 1))
(point)))))))))
(letf! ((defun org-narrow-to-subtree ()
(save-excursion
(save-match-data
(org-with-limited-levels
(narrow-to-region
(progn
(when (org-before-first-heading-p)
(org-next-visible-heading 1))
(ignore-errors (org-up-heading-all 99))
(forward-line 1)
(point))
(progn (org-end-of-subtree t t)
(when (and (org-at-heading-p) (not (eobp)))
(backward-char 1))
(point))))))))
(apply orig-fn args))))

10
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
:width (car (pdf-view-image-size))
props))))
(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))
(apply orig-fn args))))
;; 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
(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)
(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*!
(delete-window win)
;; But it must exist for org to clean up later.
(get-buffer-create "*Org Links*"))
(apply old-org-completing-read 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*!
(delete-window win)
;; ...but it must exist for org to clean up later.
(get-buffer-create "*Org Links*"))
(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)
(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))))
(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 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)
(+popup-display-buffer-stacked-side-window-fn
buffer (append '((vslot . -9999)) alist)))))
(letf! ((defun display-buffer-in-side-window (buffer alist)
(+popup-display-buffer-stacked-side-window-fn
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)
(window-in-direction
(pcase dir (`up 'above) (`down 'below) (_ dir))
window (bound-and-true-p +popup-mode) arg windmove-wrap-around t))))
(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)))
(apply orig-fn args)))