From af3eb37c8e51084261f2ad4bfe1d36fffbcfaebf Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Wed, 8 Jun 2022 17:59:53 -0500 Subject: blep --- lisp/+apheleia.el | 51 +++++++- lisp/+avy.el | 40 ++++-- lisp/+circe.el | 52 ++++---- lisp/+cus-edit.el | 2 +- lisp/+emacs.el | 17 ++- lisp/+flyspell-correct.el | 3 + lisp/+modeline.el | 22 ++-- lisp/+nyan-mode.el | 39 ++++++ lisp/+org-wc.el | 2 +- lisp/+org.el | 53 +++++++- lisp/+tab-bar.el | 314 +++++++++++++++++++++++----------------------- lisp/+window.el | 130 +++++++++++++++++++ lisp/private.el | 4 + 13 files changed, 516 insertions(+), 213 deletions(-) create mode 100644 lisp/+nyan-mode.el create mode 100644 lisp/+window.el (limited to 'lisp') diff --git a/lisp/+apheleia.el b/lisp/+apheleia.el index 469232a..df651b8 100644 --- a/lisp/+apheleia.el +++ b/lisp/+apheleia.el @@ -2,14 +2,61 @@ ;;; Code: +(require 'apheleia) +(require 'cl-lib) + ;; https://github.com/raxod502/apheleia/pull/63#issue-1077529623 -(defun +apheleia-indent-region (orig scratch callback _error) +(cl-defun +apheleia-indent-region (&key buffer scratch formatter callback &allow-other-keys) (with-current-buffer scratch (setq-local indent-line-function - (buffer-local-value 'indent-line-function orig)) + (buffer-local-value 'indent-line-function buffer)) (indent-region (point-min) (point-max)) (funcall callback))) + +;;; `setup' integration + +(require 'setup) + +(setup-define :apheleia + (lambda (name formatter &optional mode -pend) + (let* ((mode (or mode (setup-get 'mode))) + (current-formatters (and -pend + (alist-get mode apheleia-formatters)))) + `(progn + (setf (alist-get ',name apheleia-formatters) + ,formatter) + (setf (alist-get ',mode apheleia-mode-alist) + ',(pcase -pend + (:append (append (ensure-list current-formatters) + (list name))) + (:prepend (cons name (ensure-list current-formatters))) + ('nil name) + (_ (error "Improper `:apheleia' -PEND argument"))))))) + :documentation + "Register a formatter to `apheleia''s lists. +NAME is the name given to the formatter in `apheleia-formatters' +and `apheleia-mode-alist'. FORMATTER is the command paired with +NAME in `apheleia-formatters'. MODE is the mode or modes to add +NAME to in `apheleia-mode-alist'. If MODE is not given or nil, +use the setup form's MODE. Optional argument -PEND can be one of +`:append' or `:prepend', and if given will append or prepend the +given NAME to the current formatters for the MODE in +`apheleia-mode-alist', rather than replace them (the default). + +Example: +(setup + (:apheleia isort (\"isort\" \"--stdout\" \"-\") + python-mode)) +; => +(progn + (setf (alist-get 'isort apheleia-formatters) + '(\"isort\" \"--stdout\" \"-\")) + (setf (alist-get 'python-mode apheleia-mode-alist) + 'isort)) + +This form cannot be repeated, and it cannot be used as HEAD.") + (provide '+apheleia) ;;; +apheleia.el ends here diff --git a/lisp/+avy.el b/lisp/+avy.el index 8056f00..b0837a3 100644 --- a/lisp/+avy.el +++ b/lisp/+avy.el @@ -50,17 +50,35 @@ (defvar-local +avy-buffer-face-mode-face nil "The state of `buffer-face-mode' before calling `avy-with'.") -(defun +avy@un-buffer-face (&rest _) +;;; XXX: Doesn't switch back if avy errors out or quits +(defun +avy@un-buffer-face (win) "BEFORE advice on `avy-with' to disable `buffer-face-mode'." - (when buffer-face-mode - (setq +avy-buffer-face-mode-face buffer-face-mode-face) - (buffer-face-mode -1))) + (with-current-buffer (window-buffer win) + (when buffer-face-mode + (setq +avy-buffer-face-mode-face buffer-face-mode-face) + (buffer-face-mode -1)))) -(defun +avy@re-buffer-face (&rest _) +(defun +avy@re-buffer-face (win) "AFTER advice on `avy-with' to re-enable `buffer-face-mode'." - (when +avy-buffer-face-mode-face - (setq buffer-face-mode-face +avy-buffer-face-mode-face) - (buffer-face-mode +1))) + (with-current-buffer (window-buffer win) + (when +avy-buffer-face-mode-face + (setq buffer-face-mode-face +avy-buffer-face-mode-face) + (buffer-face-mode +1))) + (let ((bounds (bounds-of-thing-at-point 'symbol))) + (when (and (car bounds) + (cdr bounds)) + (pulse-momentary-highlight-region (car bounds) (cdr bounds))))) + +(defun +avy@buffer-face (fn &rest r) + "AROUND advice for avy to dis/enable `buffer-face-mode'." + (if avy-all-windows + (walk-windows #'+avy@un-buffer-face nil (eq avy-all-windows 'all-frames))) + (condition-case e + (apply fn r) + ((quit error) (message "Avy: %S" e) nil) + (:sucess e)) + (if avy-all-windows + (walk-windows #'+avy@re-buffer-face nil (eq avy-all-windows 'all-frames)))) (define-minor-mode +avy-buffer-face-mode "Turn off `buffer-face-mode' before doing Avy selections. @@ -71,11 +89,9 @@ Restore the mode after the selection." (cond (+avy-buffer-face-mode (dolist (fn +avy-buffer-face-functions) - (advice-add fn :before #'+avy@un-buffer-face)) - (advice-add 'avy--done :after #'+avy@re-buffer-face)) + (advice-add fn :around #'+avy@buffer-face))) (t (dolist (fn +avy-buffer-face-functions) - (advice-remove fn #'+avy@un-buffer-face)) - (advice-remove 'avy--done #'+avy@re-buffer-face)))) + (advice-remove fn #'+avy@buffer-face))))) (provide '+avy) ;;; avy.el ends here diff --git a/lisp/+circe.el b/lisp/+circe.el index e8c5079..382f0ab 100644 --- a/lisp/+circe.el +++ b/lisp/+circe.el @@ -45,21 +45,27 @@ ;;; Channel information +(defvar-local +circe-current-topic "" + "Cached topic of the buffer's channel.") + (defun +circe-current-topic (&optional message) "Return the topic of the current channel. When called with optional MESSAGE non-nil, or interactively, also message the current topic." (interactive "p") (let ((topic - (save-excursion - (goto-char (point-max)) - (or (re-search-backward - (rx (group "*** " - (or "Topic" "topic" "TOPIC") - (* (not ":")) ": ") - (group (+ nonl))))) - (buffer-substring-no-properties - (match-beginning 2) (match-end 2))))) + (or (save-excursion + (goto-char (point-max)) + (and (re-search-backward + (rx (group "*** " + (or "Topic" "topic" "TOPIC") + (* (not ":")) ": ") + (group (+ nonl))) + nil t) + (buffer-substring-no-properties + (match-beginning 2) (match-end 2)))) + +circe-current-topic))) + (setq +circe-current-topic topic) (when message (message "%s" topic)) topic)) @@ -86,8 +92,8 @@ replace {nick} in the string with {NO-NICK}." "Make a formatting regex for CHAR delimiters. For entry into `lui-formatting-list'." `(rx (or bol whitespace) - (group ,char (+? (not (any whitespace ,char))) ,char) - (or eol whitespace))) + (group ,char (+? (not (any whitespace ,char))) ,char) + (or eol whitespace))) ;;; Hooks & Advice @@ -139,7 +145,7 @@ For entry into `lui-formatting-list'." "What to do with `circe-server' buffers when created.") (el-patch-defun circe (network-or-server &rest server-options) - "Connect to IRC. + "Connect to IRC. Connect to the given network specified by NETWORK-OR-SERVER. @@ -157,16 +163,16 @@ All SERVER-OPTIONS are treated as variables by getting the string locally in the server buffer. See `circe-network-options' for a list of common options." - (interactive (circe--read-network-and-options)) - (let* ((options (circe--server-get-network-options network-or-server - server-options)) - (buffer (circe--server-generate-buffer options))) - (with-current-buffer buffer - (circe-server-mode) - (circe--server-set-variables options) - (circe-reconnect)) - (el-patch-swap (pop-to-buffer-same-window buffer) - (funcall +circe-server-buffer-action buffer)))) + (interactive (circe--read-network-and-options)) + (let* ((options (circe--server-get-network-options network-or-server + server-options)) + (buffer (circe--server-generate-buffer options))) + (with-current-buffer buffer + (circe-server-mode) + (circe--server-set-variables options) + (circe-reconnect)) + (el-patch-swap (pop-to-buffer-same-window buffer) + (funcall +circe-server-buffer-action buffer)))) ;;; Chat commands @@ -177,7 +183,7 @@ See `circe-network-options' for a list of common options." nil t nil))) (circe-command-ME (format "slaps %s about a bit with a large trout" nick))) -;;; Filtering functions +;;; Filtering functions --- XXX: These don't work right. ;; Set `lui-input-function' to `+lui-filter', then add the filters you want to ;; `circe-channel-mode-hook'. diff --git a/lisp/+cus-edit.el b/lisp/+cus-edit.el index 7fa46d4..4631811 100644 --- a/lisp/+cus-edit.el +++ b/lisp/+cus-edit.el @@ -50,7 +50,7 @@ pass t to it." (cl-letf (((symbol-function 'custom-set-faces) 'ignore) ((symbol-function 'custom-set-variables) (lambda (&rest args) - (apply 'custom-theme-set-variables 'user + (apply #'custom-theme-set-variables 'user (seq-filter (lambda (el) (memq (car el) +custom-variable-allowlist)) diff --git a/lisp/+emacs.el b/lisp/+emacs.el index 7c8a1a6..533d438 100644 --- a/lisp/+emacs.el +++ b/lisp/+emacs.el @@ -326,13 +326,24 @@ ARG is passed to `backward-kill-word'." (setq-default history-length t history-delete-duplicates t history-autosave-interval 60 - savehist-file (.etc "savehist.el")) + savehist-file (.etc "savehist.el") + ;; Other variables --- don't truncate any of these. + ;; `add-to-history' uses the values of these variables unless + ;; they're nil, in which case it falls back to `history-length'. + kill-ring-max 100 + mark-ring-max 100 + global-mark-ring-max 100 + regexp-search-ring-max 100 + search-ring-max 100 + kmacro-ring-max 100 + eww-history-limit 100) (dolist (var '(extended-command-history global-mark-ring + mark-ring kill-ring + kmacro-ring regexp-search-ring - search-ring - mark-ring)) + search-ring)) (add-to-list 'savehist-additional-variables var)) (savehist-mode +1)) diff --git a/lisp/+flyspell-correct.el b/lisp/+flyspell-correct.el index b995b7e..22f8c82 100644 --- a/lisp/+flyspell-correct.el +++ b/lisp/+flyspell-correct.el @@ -2,10 +2,13 @@ ;;; Code: +(require 'flyspell-correct) + (defun +flyspell-correct-buffer (&optional prefix) "Run `flyspell-correct-wrapper' on all misspelled words in the buffer. With PREFIX, prompt to change the current dictionary." (interactive "P") + (flyspell-buffer) (when prefix (let ((current-prefix-arg nil)) (call-interactively #'ispell-change-dictionary))) diff --git a/lisp/+modeline.el b/lisp/+modeline.el index 026302b..11d6a4c 100644 --- a/lisp/+modeline.el +++ b/lisp/+modeline.el @@ -347,7 +347,7 @@ The order of elements matters: whichever one matches first is applied." (defun +modeline-line (&optional spacer) (when line-number-mode (+modeline-spacer nil spacer - "%l"))) + "%3l"))) (defun +modeline-column (&optional spacer) (when column-number-mode @@ -367,8 +367,8 @@ See `line-number-mode', `column-number-mode', and `file-percentage-mode'. If `+modeline-position-function' is set to a function in the current buffer, call that function instead." (cond ((functionp +modeline-position-function) - (+modeline-spacer nil spacer - (funcall +modeline-position-function))) + (when-let* ((str (funcall +modeline-position-function))) + (+modeline-spacer nil spacer str))) (t (funcall (+modeline-concat '(+modeline-region +modeline-line +modeline-column @@ -378,10 +378,9 @@ to a function in the current buffer, call that function instead." (defun +modeline-vc (&optional spacer) "Display the version control branch of the current buffer in the modeline." ;; from https://www.gonsie.com/blorg/modeline.html, from Doom - (if-let ((backend (vc-backend buffer-file-name))) + (when-let ((backend (vc-backend buffer-file-name))) (+modeline-spacer nil spacer - (substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2))) - "")) + (substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2))))) (defun +modeline-track (&optional spacer) "Display `tracking-mode' information." @@ -473,13 +472,16 @@ to a function in the current buffer, call that function instead." (kmacro-end-macro nil))))) 'mouse-face 'mode-line-highlight)))) +(defface +nyan-mode-line nil + "Face for nyan-cat in mode line.") + (defun +modeline-nyan-on-focused (&optional spacer) "Display the cat from `nyan-mode', but only on the focused window." (require 'nyan-mode) - (when (actually-selected-window-p) - (concat (or spacer "") (nyan-create) - (propertize "." - 'face 'font-lock-comment-face)))) + (when (and (or nyan-mode (bound-and-true-p +nyan-local-mode)) + (actually-selected-window-p)) + (+modeline-spacer nil spacer + (propertize (nyan-create) 'face '+nyan-mode-line)))) (provide '+modeline) ;;; +modeline.el ends here diff --git a/lisp/+nyan-mode.el b/lisp/+nyan-mode.el new file mode 100644 index 0000000..fc6775b --- /dev/null +++ b/lisp/+nyan-mode.el @@ -0,0 +1,39 @@ +;;; +nyan-mode.el --- Extras for nyan-mode -*- lexical-binding: t; -*- + +;;; Commentary: + +;;; Code: + +;;; Update even without line number in the mode line. + +(defcustom +nyan-mode-update-functions + '( end-of-buffer beginning-of-buffer + next-line previous-line + org-next-visible-heading org-previous-visible-heading) + "Functions after which to force a mode-line update." + :type '(repeat function)) + +(defun +nyan-mode--fmlu (&rest _) + "Update the mode-line, advice-style." + (force-mode-line-update)) + +(defun +nyan-mode-advice (&rest _) + "Advise line-moving functions when in `nyan-mode'." + (dolist (fn +nyan-mode-update-functions) + (if nyan-mode + (advice-add fn :after #'+nyan-mode--fmlu) + (advice-remove fn #'+nyan-mode--fmlu)))) + +(define-minor-mode +nyan-local-mode + "My very own `nyan-mode' that isn't global and doesn't update the mode-line." + :global nil + :group 'nyan + (dolist (fn +nyan-mode-update-functions) + (if +nyan-local-mode + (advice-add fn :after #'+nyan-mode--fmlu) + (advice-remove fn #'+nyan-mode--fmlu)))) + +(define-globalized-minor-mode +nyan-mode +nyan-local-mode +nyan-local-mode) + +(provide '+nyan-mode) +;;; +nyan-mode.el ends here diff --git a/lisp/+org-wc.el b/lisp/+org-wc.el index edd88f0..89b2708 100644 --- a/lisp/+org-wc.el +++ b/lisp/+org-wc.el @@ -87,7 +87,7 @@ code... probably).") (defun +org-wc-modeline () (cond ((eq +org-wc-word-count 'huge) "huge") - (+org-wc-word-count (format " %sw" (max 0 (+ +org-wc-word-count +org-wc-correction)))))) + (+org-wc-word-count (format "%sw" (max 0 (+ +org-wc-word-count +org-wc-correction)))))) (define-minor-mode +org-wc-mode "Count words in `org-mode' buffers in the mode-line." diff --git a/lisp/+org.el b/lisp/+org.el index 6b93a7a..0d6e300 100644 --- a/lisp/+org.el +++ b/lisp/+org.el @@ -2,6 +2,7 @@ ;;; Code: +(require 'el-patch) (require 'org) (require 'org-element) (require 'ox) @@ -96,7 +97,7 @@ appropriate. In tables, insert a new row or end the table." ;; for now, it works well enough. (cond ((and itemp emptyp) (delete-region (line-beginning-position) (line-end-position)) - (insert "\n\n")) + (insert "\n")) ((or first-item-p (and itemp (not emptyp)) item-child-p) @@ -252,11 +253,11 @@ instead of the true count." ((use-region-p) (message "%d words in region" (+org-count-words-stupidly (region-beginning) - (region-end)))) + (region-end)))) (t (message "%d words in buffer" (+org-count-words-stupidly (point-min) - (point-max)))))) + (point-max)))))) ;;; org-insert-link-dwim - https://xenodium.com/emacs-dwim-do-what-i-mean/ @@ -561,7 +562,7 @@ and POST-PROCESS are passed to `org-export-to-file'." (let ((org-tmp-file "/tmp/org.html")) (org-export-to-file 'html org-tmp-file async subtreep visible-only body-only ext-plist post-process) - (start-process "xclicp" "*xclip*" + (start-process "xclip" "*xclip*" "xclip" "-verbose" "-i" org-tmp-file "-t" "text/html" @@ -684,5 +685,49 @@ This should only fire when switching to a buffer from `org-agenda'." (advice-remove 'org-agenda #'+org-agenda-inhibit-hooks) (advice-remove 'org-agenda-switch-to #'+org-agenda-switch-run-hooks)))) + +;;; "Fix" `org-align-tags' + +(el-patch-defun org-align-tags (&optional all) + "Align tags in current entry. +When optional argument ALL is non-nil, align all tags in the +visible part of the buffer." + (let ((get-indent-column + (lambda () + (let ((offset (el-patch-swap + (if (bound-and-true-p org-indent-mode) + (* (1- org-indent-indentation-per-level) + (1- (org-current-level))) + 0) + 0))) + (+ org-tags-column + (if (> org-tags-column 0) (- offset) offset)))))) + (if (and (not all) (org-at-heading-p)) + (org--align-tags-here (funcall get-indent-column)) + (save-excursion + (if all + (progn + (goto-char (point-min)) + (while (re-search-forward org-tag-line-re nil t) + (org--align-tags-here (funcall get-indent-column)))) + (org-back-to-heading t) + (org--align-tags-here (funcall get-indent-column))))))) + +;;; Meta-return + +(defun +org-meta-return (&optional arg) + "Insert a new line, or wrap a region in a table. +See `org-meta-return', but `+org-return-dwim' does most of the +stuff I would want out of that function already. + +When called with a prefix ARG, will still unconditionally call +`org-insert-heading'." + (interactive "P") + (org-fold-check-before-invisible-edit 'insert) + (or (run-hook-with-args-until-success 'org-metareturn-hook) ; Allow customizations + (call-interactively (cond (arg #'org-insert-heading) + ((org-at-table-p) #'org-table-wrap-region) + (t #'org-return))))) + (provide '+org) ;;; +org.el ends here diff --git a/lisp/+tab-bar.el b/lisp/+tab-bar.el index 3e6968e..7ff991c 100644 --- a/lisp/+tab-bar.el +++ b/lisp/+tab-bar.el @@ -12,8 +12,8 @@ (defface +tab-bar-extra '((t :inherit (tab-bar font-lock-comment-face))) - "Tab bar face for extra information, like the menu-bar and time." - :group 'basic-faces) + "Tab bar face for extra information, like the menu-bar and time." + :group 'basic-faces) ;; Common @@ -35,97 +35,97 @@ (defun +tab-bar-tracking-mode () "Display `tracking-mode-line-buffers' in the tab-bar." ;; TODO: write something to convert a mode-line construct to a tab-bar - ;; construct. - (when (and (bound-and-true-p tracking-mode) - (not (and +tracking-hide-when-org-clocking - (bound-and-true-p org-clock-current-task)))) - (cons (when (> (length tracking-mode-line-buffers) 0) - '(track-mode-line-separator menu-item " " ignore)) - (cl-loop for i from 0 below (length tracking-mode-line-buffers) - as item = (nth i tracking-mode-line-buffers) - collect (append (list (intern (format "tracking-mode-line-%s" i)) - 'menu-item - (string-trim (format-mode-line item))) - (if-let ((keymap (plist-get item 'keymap))) - (list (alist-get 'down-mouse-1 (cdadr keymap))) - (list #'ignore)) - (when-let ((help (plist-get item 'help-echo))) - (list :help help))))))) + ;; construct. + (when (and (bound-and-true-p tracking-mode) + (not (and +tracking-hide-when-org-clocking + (bound-and-true-p org-clock-current-task)))) + (cons (when (> (length tracking-mode-line-buffers) 0) + '(track-mode-line-separator menu-item " " ignore)) + (cl-loop for i from 0 below (length tracking-mode-line-buffers) + as item = (nth i tracking-mode-line-buffers) + collect (append (list (intern (format "tracking-mode-line-%s" i)) + 'menu-item + (string-trim (format-mode-line item))) + (if-let ((keymap (plist-get item 'keymap))) + (list (alist-get 'down-mouse-1 (cdadr keymap))) + (list #'ignore)) + (when-let ((help (plist-get item 'help-echo))) + (list :help help))))))) (defun +tab-bar-timer () "Display `+timer-string' in the tab-bar." - (when +timer-string + (when (> (length (bound-and-true-p +timer-string)) 0) `((timer-string menu-item ,(concat " " +timer-string) - (lambda (ev) - (interactive "e") - (cond ((not +timer-timer) nil) - ((equal +timer-string +timer-running-string) - (popup-menu - '("Running timer" - ["Cancel timer" +timer-cancel t]) - ev)) - (t (setq +timer-string "")))))))) + (lambda (ev) + (interactive "e") + (cond ((not +timer-timer) nil) + ((equal +timer-string +timer-running-string) + (popup-menu + '("Running timer" + ["Cancel timer" +timer-cancel t]) + ev)) + (t (setq +timer-string "")))))))) (defun +tab-bar-date () "Display `display-time-string' in the tab-bar." (when display-time-mode `((date-time-string menu-item ,(substring-no-properties (concat " " (string-trim display-time-string))) - (lambda (ev) - (interactive "e") - (popup-menu - (append '("Timer") - (let (r) - (dolist (time '(3 5 10)) - (push (vector (format "Timer for %d minutes" time) - `(lambda () (interactive) - (+timer ,time)) - :active t) - r)) - (nreverse r)) - '(["Timer for ..." +timer t])) - ev)) - :help (discord-date-string))))) + (lambda (ev) + (interactive "e") + (popup-menu + (append '("Timer") + (let (r) + (dolist (time '(3 5 10)) + (push (vector (format "Timer for %d minutes" time) + `(lambda () (interactive) + (+timer ,time)) + :active t) + r)) + (nreverse r)) + '(["Timer for ..." +timer t])) + ev)) + :help (discord-date-string))))) (defun +tab-bar-notmuch-count () "Display a notmuch count in the tab-bar." (when (and (executable-find "notmuch") (featurep 'notmuch)) (let* ((counts (ignore-errors (notmuch-hello-query-counts notmuch-saved-searches))) - (next (cl-find "inbox" counts :key (lambda (l) (plist-get l :name)) :test 'equal)) + (next (cl-find "inbox+unread" counts :key (lambda (l) (plist-get l :name)) :test 'equal)) (next-count (plist-get next :count))) (when (and next-count (> next-count 0)) `((notmuch-count menu-item ,(format " |%s|" next-count) - ignore - :help ,(format "%s mails requiring attention." next-count))))))) + ignore + :help ,(format "%s mails requiring attention." next-count))))))) (defun +tab-bar-org-clock () "Display `org-mode-line-string' in the tab-bar." (when (and (fboundp 'org-clocking-p) (org-clocking-p)) ;; org-mode-line-string - `((org-clocking menu-item - ,org-mode-line-string - (lambda (ev) - (interactive "e") - (let ((menu (make-sparse-keymap - (or org-clock-current-task "Org-Clock")))) - (map-keymap (lambda (key binding) - (when (consp binding) - (define-key-after menu (vector key) - (copy-sequence binding)))) - (org-clock-menu)) - (message "%S" ev) - (popup-menu menu ev))) - :help ,(or (replace-regexp-in-string - (rx "[[" (group (* (not "]"))) - "][" (group (* (not "]"))) - "]]") - "\\2" - org-clock-current-task) - "Org-Clock"))))) + `((org-clocking menu-item + ,org-mode-line-string + (lambda (ev) + (interactive "e") + (let ((menu (make-sparse-keymap + (or org-clock-current-task "Org-Clock")))) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (org-clock-menu)) + (message "%S" ev) + (popup-menu menu ev))) + :help ,(or (replace-regexp-in-string + (rx "[[" (group (* (not "]"))) + "][" (group (* (not "]"))) + "]]") + "\\2" + org-clock-current-task) + "Org-Clock"))))) (defcustom +tab-bar-emms-max-length 24 "Maximum length of `+tab-bar-emms'." @@ -139,8 +139,8 @@ (- +tab-bar-emms-max-length 2)))) `(emms-now-playing menu-item ,(concat "{" now-playing "}" " ") - emms-pause - ( :help ,(emms-mode-line-playlist-current)))))) + emms-pause + ( :help ,(emms-mode-line-playlist-current)))))) (defun +tab-bar-bongo () "Display Bongo now playing information." @@ -160,22 +160,22 @@ "\\1: \\3" (bongo-formatted-infoset)) ;; This isn't right - (- (min 50 (/ (frame-width) 3 )) 2))) + (- (min 50 (/ (frame-width) 3 )) 2))) "}") - (lambda () (interactive) - (let ((bongo-playlist-buffer - ;; XXX: I'm sure this is terribly inefficient - (cl-some (lambda (b) - (with-current-buffer b - (when-let* ((modep (derived-mode-p - 'bongo-playlist-mode)) - (bongo-playlist-buffer b) - (playingp (bongo-playing-p))) - b))) - (buffer-list)))) - (with-bongo-playlist-buffer - (bongo-pause/resume)))) - :help ,(funcall bongo-header-line-function))))) + (lambda () (interactive) + (let ((bongo-playlist-buffer + ;; XXX: I'm sure this is terribly inefficient + (cl-some (lambda (b) + (with-current-buffer b + (when-let* ((modep (derived-mode-p + 'bongo-playlist-mode)) + (bongo-playlist-buffer b) + (playingp (bongo-playing-p))) + b))) + (buffer-list)))) + (with-bongo-playlist-buffer + (bongo-pause/resume)))) + :help ,(funcall bongo-header-line-function))))) (defvar +tab-bar-show-original nil "Original value of `tab-bar-show'.") @@ -192,49 +192,49 @@ ;;; FIXME this doesn't work... ;; (defvar +tab-bar-tab-min-width 8 -;; "Minimum width of a tab on the tab bar.") + ;; "Minimum width of a tab on the tab bar.") ;; (defvar +tab-bar-tab-max-width 24 -;; "Maximum width of a tab on the tab bar.") + ;; "Maximum width of a tab on the tab bar.") ;; (defun +tab-bar-fluid-calculate-width () -;; "Calculate the width of each tab in the tab-bar." -;; (let* ((tab-bar-list (cdr (tab-bar-make-keymap-1))) -;; (tab-bar-avail-width (frame-width)) -;; (tab-bar-tab-count (length (tab-bar-tabs))) -;; (tab-bar-close-button-char-width 1) -;; (tab-bar-add-tab-button-char-width 1) -;; (tab-bar-total-width -;; (length (mapconcat -;; (lambda (el) -;; (when-let ((str (car-safe (cdr-safe (cdr-safe el))))) -;; (substring-no-properties (eval str)))) -;; tab-bar-list))) -;; (tab-bar-total-tab-width -;; (+ (* tab-bar-tab-count tab-bar-close-button-char-width) -;; tab-bar-add-tab-button-char-width -;; (length (mapconcat -;; (lambda (el) -;; (substring-no-properties (alist-get 'name el))) -;; (tab-bar-tabs))))) -;; (tab-bar-total-nontab-width (- tab-bar-total-width -;; tab-bar-total-tab-width))) -;; (min +tab-bar-tab-max-width -;; (max +tab-bar-tab-min-width -;; (/ (- tab-bar-avail-width -;; tab-bar-total-tab-width -;; tab-bar-total-nontab-width) -;; tab-bar-tab-count))))) + ;; "Calculate the width of each tab in the tab-bar." + ;; (let* ((tab-bar-list (cdr (tab-bar-make-keymap-1))) + ;; (tab-bar-avail-width (frame-width)) + ;; (tab-bar-tab-count (length (tab-bar-tabs))) + ;; (tab-bar-close-button-char-width 1) + ;; (tab-bar-add-tab-button-char-width 1) + ;; (tab-bar-total-width + ;; (length (mapconcat + ;; (lambda (el) + ;; (when-let ((str (car-safe (cdr-safe (cdr-safe el))))) + ;; (substring-no-properties (eval str)))) + ;; tab-bar-list))) + ;; (tab-bar-total-tab-width + ;; (+ (* tab-bar-tab-count tab-bar-close-button-char-width) + ;; tab-bar-add-tab-button-char-width + ;; (length (mapconcat + ;; (lambda (el) + ;; (substring-no-properties (alist-get 'name el))) + ;; (tab-bar-tabs))))) + ;; (tab-bar-total-nontab-width (- tab-bar-total-width + ;; tab-bar-total-tab-width))) + ;; (min +tab-bar-tab-max-width + ;; (max +tab-bar-tab-min-width + ;; (/ (- tab-bar-avail-width + ;; tab-bar-total-tab-width + ;; tab-bar-total-nontab-width) + ;; tab-bar-tab-count))))) ;; (defun +tab-bar-fluid-width () -;; "Generate the tab name to fluidly fit in the given space." -;; (let* ((tab-file-name (buffer-file-name (window-buffer -;; (minibuffer-selected-window))))) -;; (format (format " %%s%%%ds" (+tab-bar-fluid-calculate-width)) -;; (if tab-file-name -;; (file-name-nondirectory tab-file-name) -;; (+tab-bar-tab-name-truncated-left)) -;; " "))) + ;; "Generate the tab name to fluidly fit in the given space." + ;; (let* ((tab-file-name (buffer-file-name (window-buffer + ;; (minibuffer-selected-window))))) + ;; (format (format " %%s%%%ds" (+tab-bar-fluid-calculate-width)) + ;; (if tab-file-name + ;; (file-name-nondirectory tab-file-name) + ;; (+tab-bar-tab-name-truncated-left)) + ;; " "))) (defun +tab-bar-tab-name-truncated-left () "Generate the tab name from the buffer of the selected window. @@ -259,13 +259,13 @@ name to the left." (defun +tab-bar-format-align-right () "Align the rest of tab bar items to the right, pixel-wise." ;; XXX: ideally, wouldn't require `shr' here - (require 'shr) ; `shr-string-pixel-width' - (let* ((rest (cdr (memq '+tab-bar-format-align-right tab-bar-format))) - (rest (tab-bar-format-list rest)) - (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) - (hpos (shr-string-pixel-width rest)) - (str (propertize " " 'display `(space :align-to (- right (,hpos)))))) - `((align-right menu-item ,str ignore)))) + (require 'shr) ; `shr-string-pixel-width' + (let* ((rest (cdr (memq '+tab-bar-format-align-right tab-bar-format))) + (rest (tab-bar-format-list rest)) + (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) + (hpos (shr-string-pixel-width rest)) + (str (propertize " " 'display `(space :align-to (- right (,hpos)))))) + `((align-right menu-item ,str ignore)))) ;;; Menu bar @@ -309,18 +309,18 @@ Used by `tab-bar-format-menu-bar'." `((current-tab menu-item ,(funcall tab-bar-tab-name-format-function tab i) - ignore - :help "Current tab"))) + ignore + :help "Current tab"))) (t `((,(intern (format "tab-%i" i)) - menu-item - ,(funcall tab-bar-tab-name-format-function tab i) - ,(alist-get 'binding tab) - :help "Click to visit tab")))) + menu-item + ,(funcall tab-bar-tab-name-format-function tab i) + ,(alist-get 'binding tab) + :help "Click to visit tab")))) (when (alist-get 'close-binding tab) `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i))) - menu-item "" - ,(alist-get 'close-binding tab))))))) + menu-item "" + ,(alist-get 'close-binding tab))))))) ;; Emacs 27 @@ -334,7 +334,7 @@ This is :filter-return advice for `tab-bar-make-keymap-1'." ,reserve))))) (prog1 (append output `((align-right menu-item ,str nil)) - (+tab-bar-misc-info))))) + (+tab-bar-misc-info))))) ;; Emacs 28 @@ -353,27 +353,27 @@ This is :filter-return advice for `tab-bar-make-keymap-1'." (define-minor-mode +tab-bar-misc-info-mode "Show the `mode-line-misc-info' in the `tab-bar'." :lighter "" - :global t - (if +tab-bar-misc-info-mode - (progn ; Enable - (setq +tab-bar-show-original tab-bar-show) - (cond - ((boundp 'tab-bar-format) ; Emacs 28 - (setq +tab-bar-format-original tab-bar-format) - (unless (memq '+tab-bar-misc-info tab-bar-format) - (setq tab-bar-format - (append tab-bar-format (+tab-bar-misc-info-28))))) - ((fboundp 'tab-bar-make-keymap-1) ; Emacs 27 - (advice-add 'tab-bar-make-keymap-1 :filter-return - '+tab-bar-misc-info-27))) - (setq tab-bar-show t)) - (progn ; Disable - (setq tab-bar-show +tab-bar-show-original) - (cond - ((boundp 'tab-bar-format) ; Emacs 28 - (setq tab-bar-format +tab-bar-format-original)) - ((fboundp 'tab-bar-make-keymap-1) ; Emacs 27 - (advice-remove 'tab-bar-make-keymap-1 '+tab-bar-misc-info-27)))))) + :global t + (if +tab-bar-misc-info-mode + (progn ; Enable + (setq +tab-bar-show-original tab-bar-show) + (cond + ((boundp 'tab-bar-format) ; Emacs 28 + (setq +tab-bar-format-original tab-bar-format) + (unless (memq '+tab-bar-misc-info tab-bar-format) + (setq tab-bar-format + (append tab-bar-format (+tab-bar-misc-info-28))))) + ((fboundp 'tab-bar-make-keymap-1) ; Emacs 27 + (advice-add 'tab-bar-make-keymap-1 :filter-return + '+tab-bar-misc-info-27))) + (setq tab-bar-show t)) + (progn ; Disable + (setq tab-bar-show +tab-bar-show-original) + (cond + ((boundp 'tab-bar-format) ; Emacs 28 + (setq tab-bar-format +tab-bar-format-original)) + ((fboundp 'tab-bar-make-keymap-1) ; Emacs 27 + (advice-remove 'tab-bar-make-keymap-1 '+tab-bar-misc-info-27)))))) diff --git a/lisp/+window.el b/lisp/+window.el new file mode 100644 index 0000000..52b3712 --- /dev/null +++ b/lisp/+window.el @@ -0,0 +1,130 @@ +;;; +window.el --- Fixes for Emacs's window.el -*- lexical-binding: t; -*- + +;;; Commentary: + +;; Do I want to propose this change in the Emacs ML? + +;;; Code: + +(require 'window) + +;;; Split windows based on `window-total-width', not `window-width' +;; I have to just redefine these functions because the check is really deep in +;; there. + +(defun window-splittable-p (window &optional horizontal) + "Return non-nil if `split-window-sensibly' may split WINDOW. +Optional argument HORIZONTAL nil or omitted means check whether +`split-window-sensibly' may split WINDOW vertically. HORIZONTAL +non-nil means check whether WINDOW may be split horizontally. + +WINDOW may be split vertically when the following conditions +hold: +- `window-size-fixed' is either nil or equals `width' for the + buffer of WINDOW. +- `split-height-threshold' is an integer and WINDOW is at least as + high as `split-height-threshold'. +- When WINDOW is split evenly, the emanating windows are at least + `window-min-height' lines tall and can accommodate at least one + line plus - if WINDOW has one - a mode line. + +WINDOW may be split horizontally when the following conditions +hold: +- `window-size-fixed' is either nil or equals `height' for the + buffer of WINDOW. +- `split-width-threshold' is an integer and WINDOW is at least as + wide as `split-width-threshold'. +- When WINDOW is split evenly, the emanating windows are at least + `window-min-width' or two (whichever is larger) columns wide." + (when (and (window-live-p window) + (not (window-parameter window 'window-side))) + (with-current-buffer (window-buffer window) + (if horizontal + ;; A window can be split horizontally when its width is not + ;; fixed, it is at least `split-width-threshold' columns wide + ;; and at least twice as wide as `window-min-width' and 2 (the + ;; latter value is hardcoded). + (and (memq window-size-fixed '(nil height)) + ;; Testing `window-full-width-p' here hardly makes any + ;; sense nowadays. This can be done more intuitively by + ;; setting up `split-width-threshold' appropriately. + (numberp split-width-threshold) + (>= (window-total-width window) + (max split-width-threshold + (* 2 (max window-min-width 2))))) + ;; A window can be split vertically when its height is not + ;; fixed, it is at least `split-height-threshold' lines high, + ;; and it is at least twice as high as `window-min-height' and 2 + ;; if it has a mode line or 1. + (and (memq window-size-fixed '(nil width)) + (numberp split-height-threshold) + (>= (window-height window) + (max split-height-threshold + (* 2 (max window-min-height + (if mode-line-format 2 1)))))))))) + +(defun split-window-sensibly (&optional window) + "Split WINDOW in a way suitable for `display-buffer'. +WINDOW defaults to the currently selected window. +If `split-height-threshold' specifies an integer, WINDOW is at +least `split-height-threshold' lines tall and can be split +vertically, split WINDOW into two windows one above the other and +return the lower window. Otherwise, if `split-width-threshold' +specifies an integer, WINDOW is at least `split-width-threshold' +columns wide and can be split horizontally, split WINDOW into two +windows side by side and return the window on the right. If this +can't be done either and WINDOW is the only window on its frame, +try to split WINDOW vertically disregarding any value specified +by `split-height-threshold'. If that succeeds, return the lower +window. Return nil otherwise. + +By default `display-buffer' routines call this function to split +the largest or least recently used window. To change the default +customize the option `split-window-preferred-function'. + +You can enforce this function to not split WINDOW horizontally, +by setting (or binding) the variable `split-width-threshold' to +nil. If, in addition, you set `split-height-threshold' to zero, +chances increase that this function does split WINDOW vertically. + +In order to not split WINDOW vertically, set (or bind) the +variable `split-height-threshold' to nil. Additionally, you can +set `split-width-threshold' to zero to make a horizontal split +more likely to occur. + +Have a look at the function `window-splittable-p' if you want to +know how `split-window-sensibly' determines whether WINDOW can be +split." + (let ((window (or window (selected-window)))) + (or (and (window-splittable-p window) + ;; Split window vertically. + (with-selected-window window + (split-window-below))) + (and (window-splittable-p window t) + ;; Split window horizontally. + (with-selected-window window + (split-window-right))) + (and + ;; If WINDOW is the only usable window on its frame (it is + ;; the only one or, not being the only one, all the other + ;; ones are dedicated) and is not the minibuffer window, try + ;; to split it vertically disregarding the value of + ;; `split-height-threshold'. + (let ((frame (window-frame window))) + (or + (eq window (frame-root-window frame)) + (catch 'done + (walk-window-tree (lambda (w) + (unless (or (eq w window) + (window-dedicated-p w)) + (throw 'done nil))) + frame nil 'nomini) + t))) + (not (window-minibuffer-p window)) + (let ((split-height-threshold 0)) + (when (window-splittable-p window) + (with-selected-window window + (split-window-below)))))))) + +(provide '+window) +;;; +window.el ends here diff --git a/lisp/private.el b/lisp/private.el index f9c4753..4f6115e 100644 --- a/lisp/private.el +++ b/lisp/private.el @@ -15,5 +15,9 @@ "Private secretive secrets inside.") (add-to-list 'load-path private/) +;; Load random private stuff + +(require '_acdw) + (provide 'private) ;;; private.el ends here -- cgit 1.4.1-21-gabe81