emacs: various cosmetic improvements

This commit is contained in:
Jonas Bernoulli 2021-01-13 18:37:50 +01:00 committed by David Bremner
parent 1bbbde4a0c
commit 16b2db0986
9 changed files with 125 additions and 148 deletions

View file

@ -21,6 +21,8 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
(require 'message)
(require 'notmuch-parser)
(require 'notmuch-lib)
@ -160,15 +162,12 @@ matching `notmuch-address-completion-headers-regexp'."
(message "calling notmuch-address-message-insinuate is no longer needed"))
(defun notmuch-address-setup ()
(let* ((setup-company (and notmuch-address-use-company
(require 'company nil t)))
(pair (cons notmuch-address-completion-headers-regexp
#'notmuch-address-expand-name)))
(when setup-company
(notmuch-company-setup))
(unless (member pair message-completion-alist)
(setq message-completion-alist
(push pair message-completion-alist)))))
(when (and notmuch-address-use-company
(require 'company nil t))
(notmuch-company-setup))
(cl-pushnew (cons notmuch-address-completion-headers-regexp
#'notmuch-address-expand-name)
message-completion-alist :test #'equal))
(defun notmuch-address-toggle-internal-completion ()
"Toggle use of internal completion for current buffer.
@ -264,9 +263,6 @@ requiring external commands."
(let ((name-addr (plist-get result :name-addr)))
(puthash name-addr t notmuch-address-completions)))
(defun notmuch-address-harvest-handle-result (obj)
(notmuch-address-harvest-addr obj))
(defun notmuch-address-harvest-filter (proc string)
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
@ -274,7 +270,7 @@ requiring external commands."
(goto-char (point-max))
(insert string))
(notmuch-sexp-parse-partial-list
'notmuch-address-harvest-handle-result (process-buffer proc)))))
'notmuch-address-harvest-addr (process-buffer proc)))))
(defvar notmuch-address-harvest-procs '(nil . nil)
"The currently running harvests.

View file

@ -432,8 +432,7 @@ supported for \"Customized queries section\" items."
;; If an existing saved search with this name exists, remove it.
(setq notmuch-saved-searches
(cl-loop for elem in notmuch-saved-searches
if (not (equal name
(notmuch-saved-search-get elem :name)))
unless (equal name (notmuch-saved-search-get elem :name))
collect elem))
;; Add the new one.
(customize-save-variable 'notmuch-saved-searches
@ -481,18 +480,14 @@ diagonal."
append (notmuch-hello-reflect-generate-row ncols nrows row list))))
(defun notmuch-hello-widget-search (widget &rest _ignore)
(cond
((eq (widget-get widget :notmuch-search-type) 'tree)
(notmuch-tree (widget-get widget
:notmuch-search-terms)))
((eq (widget-get widget :notmuch-search-type) 'unthreaded)
(notmuch-unthreaded (widget-get widget
:notmuch-search-terms)))
(cl-case (widget-get widget :notmuch-search-type)
(tree
(notmuch-tree (widget-get widget :notmuch-search-terms)))
(unthreaded
(notmuch-unthreaded (widget-get widget :notmuch-search-terms)))
(t
(notmuch-search (widget-get widget
:notmuch-search-terms)
(widget-get widget
:notmuch-search-oldest-first)))))
(notmuch-search (widget-get widget :notmuch-search-terms)
(widget-get widget :notmuch-search-oldest-first)))))
(defun notmuch-saved-search-count (search)
(car (process-lines notmuch-command "count" search)))
@ -823,8 +818,7 @@ Complete list of currently available key bindings:
;; instead of a space to make `show-trailing-whitespace'
;; happy, i.e. avoid it marking the whole line as trailing
;; spaces.
(widget-insert ".")
(put-text-property (1- (point)) (point) 'invisible t)
(widget-insert (propertize "." 'invisible t))
(widget-insert "\n"))
(defun notmuch-hello-insert-recent-searches ()

View file

@ -63,8 +63,8 @@ fast way to jump to a saved search from anywhere in Notmuch."
(setq action-map (nreverse action-map))
(if action-map
(notmuch-jump action-map "Search: ")
(error "To use notmuch-jump, \
please customize shortcut keys in notmuch-saved-searches."))))
(error "To use notmuch-jump, %s"
"please customize shortcut keys in notmuch-saved-searches."))))
(defvar notmuch-jump--action nil)

View file

@ -192,8 +192,8 @@ will be signaled.
Otherwise the output will be returned."
(with-temp-buffer
(let* ((status (apply #'call-process notmuch-command nil t nil args))
(output (buffer-string)))
(let ((status (apply #'call-process notmuch-command nil t nil args))
(output (buffer-string)))
(notmuch-check-exit-status status (cons notmuch-command args) output)
output)))
@ -248,7 +248,8 @@ displays both values separately."
(len (length val)))
;; Trim off the trailing newline (if the value is empty or not
;; configured, there will be no newline)
(if (and (> len 0) (= (aref val (- len 1)) ?\n))
(if (and (> len 0)
(= (aref val (- len 1)) ?\n))
(substring val 0 -1)
val)))
@ -538,13 +539,12 @@ This replaces spaces, percents, and double quotes in STR with
;;; Generic Utilities
(defun notmuch-plist-delete (plist property)
(let* ((xplist (cons nil plist))
(pred xplist))
(while (cdr pred)
(when (eq (cadr pred) property)
(setcdr pred (cdddr pred)))
(setq pred (cddr pred)))
(cdr xplist)))
(let (p)
(while plist
(unless (eq property (car plist))
(setq p (plist-put p (car plist) (cadr plist))))
(setq plist (cddr plist)))
p))
;;; MML Utilities
@ -555,8 +555,10 @@ This replaces spaces, percents, and double quotes in STR with
(if (or (string= (cadr st1) "*")
(string= (cadr st2) "*"))
;; Comparison of content types should be case insensitive.
(string= (downcase (car st1)) (downcase (car st2)))
(string= (downcase t1) (downcase t2)))))
(string= (downcase (car st1))
(downcase (car st2)))
(string= (downcase t1)
(downcase t2)))))
(defvar notmuch-multipart/alternative-discouraged
'(;; Avoid HTML parts.

View file

@ -107,16 +107,13 @@ by notmuch-mua-mail."
;; Old style - no longer works.
(error "Invalid `notmuch-fcc-dirs' setting (old style)"))
((listp notmuch-fcc-dirs)
(let* ((from (message-field-value "From"))
(match
(catch 'first-match
(dolist (re-folder notmuch-fcc-dirs)
(when (string-match-p (car re-folder) from)
(throw 'first-match re-folder))))))
(if match
(cdr match)
(message "No Fcc header added.")
nil)))
(or (seq-some (let ((from (message-field-value "From")))
(pcase-lambda (`(,regexp . ,folder))
(and (string-match-p regexp from)
folder)))
notmuch-fcc-dirs)
(progn (message "No Fcc header added.")
nil)))
(t
(error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
(when subdir
@ -128,9 +125,9 @@ by notmuch-mua-mail."
;; Notmuch insert does not accept absolute paths, so check the user
;; really want this header inserted.
(when (or (not (= (elt subdir 0) ?/))
(y-or-n-p
(format "Fcc header %s is an absolute path and notmuch insert is requested.
Insert header anyway? " subdir)))
(y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir
"and notmuch insert is requested."
"Insert header anyway? ")))
(message-add-header (concat "Fcc: " subdir))))
(defun notmuch-maildir-add-file-style-fcc-header (subdir)
@ -173,7 +170,7 @@ This is taken from the function message-do-fcc."
"Process Fcc headers in the current buffer.
This is a rearranged version of message mode's message-do-fcc."
(let (list file)
(let (files file)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@ -183,13 +180,11 @@ This is a rearranged version of message mode's message-do-fcc."
(save-restriction
(message-narrow-to-headers)
(while (setq file (message-fetch-field "fcc" t))
(push file list)
(push file files)
(message-remove-header "fcc" nil t)))
(notmuch-maildir-setup-message-for-saving)
;; Process FCC operations.
(while list
(setq file (pop list))
(notmuch-fcc-handler file))
(mapc #'notmuch-fcc-handler files)
(kill-buffer (current-buffer)))))))
(defun notmuch-fcc-handler (fcc-header)
@ -201,7 +196,8 @@ normal fcc."
(message "Doing Fcc...")
(if notmuch-maildir-use-notmuch-insert
(notmuch-maildir-fcc-with-notmuch-insert fcc-header)
(notmuch-maildir-fcc-file-fcc fcc-header)))
(notmuch-maildir-fcc-file-fcc fcc-header))
(message "Doing Fcc...done"))
;;; Functions for saving a message using notmuch insert.
@ -230,9 +226,8 @@ quoting each space with an immediately preceding backslash
or surrounding the entire folder name in double quotes.
If CREATE is non-nil then create the folder if necessary."
(let* ((args (split-string-and-unquote fcc-header))
(folder (car args))
(tags (cdr args)))
(pcase-let ((`(,folder . ,tags)
(split-string-and-unquote fcc-header)))
(condition-case nil
(notmuch-maildir-notmuch-insert-current-buffer folder create tags)
;; Since there are many reasons notmuch insert could fail, e.g.,
@ -265,7 +260,7 @@ If CREATE is non-nil then create the folder if necessary."
(let* ((ftime (float-time))
(microseconds (mod (* 1000000 ftime) 1000000))
(hostname (notmuch-maildir-fcc-host-fixer (system-name))))
(setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1))
(cl-incf notmuch-maildir-fcc-count)
(format "%d.%d_%d_%d.%s"
ftime
(emacs-pid)
@ -298,9 +293,7 @@ if successful, nil if not."
(write-file (concat destdir "/tmp/" msg-id))
msg-id)
(t
(error (format "Can't write to %s. Not a maildir."
destdir))
nil))))
(error "Can't write to %s. Not a maildir." destdir)))))
(defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
(add-name-to-file
@ -345,16 +338,12 @@ return t if successful, and nil otherwise."
(catch 'link-error
(let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
(when msg-id
(cond (mark-seen
(condition-case nil
(notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
(file-already-exists
(throw 'link-error nil))))
(t
(condition-case nil
(notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)
(file-already-exists
(throw 'link-error nil))))))
(condition-case nil
(if mark-seen
(notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
(notmuch-maildir-fcc-move-tmp-to-new destdir msg-id))
(file-already-exists
(throw 'link-error nil))))
(delete-file (concat destdir "/tmp/" msg-id))))
t)))

View file

@ -179,13 +179,11 @@ Typically this is added to `notmuch-mua-send-hook'."
(defun notmuch-mua-get-switch-function ()
"Get a switch function according to `notmuch-mua-compose-in'."
(cond ((eq notmuch-mua-compose-in 'current-window)
'switch-to-buffer)
((eq notmuch-mua-compose-in 'new-window)
'switch-to-buffer-other-window)
((eq notmuch-mua-compose-in 'new-frame)
'switch-to-buffer-other-frame)
(t (error "Invalid value for `notmuch-mua-compose-in'"))))
(pcase notmuch-mua-compose-in
('current-window 'switch-to-buffer)
('new-window 'switch-to-buffer-other-window)
('new-frame 'switch-to-buffer-other-frame)
(_ (error "Invalid value for `notmuch-mua-compose-in'"))))
(defun notmuch-mua-maybe-set-window-dedicated ()
"Set the selected window as dedicated according to `notmuch-mua-compose-in'."
@ -375,12 +373,10 @@ instead of `message-mode' and SWITCH-FUNCTION is mandatory."
(select-window window))
(funcall switch-function buffer)
(set-buffer buffer))
(when (and (buffer-modified-p)
(not (prog1
(y-or-n-p
"Message already being composed; erase? ")
(message nil))))
(error "Message being composed")))
(when (buffer-modified-p)
(if (y-or-n-p "Message already being composed; erase? ")
(message nil)
(error "Message being composed"))))
(funcall switch-function name)
(set-buffer name))
(erase-buffer)
@ -611,8 +607,10 @@ unencrypted. Really send? "))))
;;; _
(define-mail-user-agent 'notmuch-user-agent
'notmuch-mua-mail 'notmuch-mua-send-and-exit
'notmuch-mua-kill-buffer 'notmuch-mua-send-hook)
'notmuch-mua-mail
'notmuch-mua-send-and-exit
'notmuch-mua-kill-buffer
'notmuch-mua-send-hook)
;; Add some more headers to the list that `message-mode' hides when
;; composing a message.

View file

@ -41,11 +41,9 @@ is a possibly empty forest of replies."
(defun notmuch-query-map-aux (mapper function seq)
"Private function to do the actual mapping and flattening."
(apply 'append
(mapcar
(lambda (tree)
(funcall mapper function tree))
seq)))
(cl-mapcan (lambda (tree)
(funcall mapper function tree))
seq))
(defun notmuch-query-map-threads (fn threads)
"Apply function FN to every thread in THREADS.
@ -63,7 +61,8 @@ Flatten results to a list. See the function
"Apply function FN to every message in TREE.
Flatten results to a list. See the function
`notmuch-query-get-threads' for more information."
(cons (funcall fn (car tree)) (notmuch-query-map-forest fn (cadr tree))))
(cons (funcall fn (car tree))
(notmuch-query-map-forest fn (cadr tree))))
;;; Predefined queries

View file

@ -454,8 +454,9 @@ present or a \"-\" to indicate that the tag should be removed
from TAGS if present."
(let ((result-tags (copy-sequence tags)))
(dolist (tag-change tag-changes)
(let ((op (string-to-char tag-change))
(tag (unless (string= tag-change "") (substring tag-change 1))))
(let ((op (aref tag-change 0))
(tag (and (not (string= tag-change ""))
(substring tag-change 1))))
(cl-case op
(?+ (unless (member tag result-tags)
(push tag result-tags)))
@ -482,13 +483,12 @@ messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
directly, so that hooks specified in notmuch-before-tag-hook and
notmuch-after-tag-hook will be run."
;; Perform some validation
(mapc (lambda (tag-change)
(unless (string-match-p "^[-+]\\S-+$" tag-change)
(error "Tag must be of the form `+this_tag' or `-that_tag'")))
tag-changes)
(dolist (tag-change tag-changes)
(unless (string-match-p "^[-+]\\S-+$" tag-change)
(error "Tag must be of the form `+this_tag' or `-that_tag'")))
(unless query
(error "Nothing to tag!"))
(unless (null tag-changes)
(when tag-changes
(run-hooks 'notmuch-before-tag-hook)
(if (<= (length query) notmuch-tag-argument-limit)
(apply 'notmuch-call-notmuch-process "tag"

View file

@ -179,7 +179,7 @@ there will be called at other points of notmuch execution."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map notmuch-common-keymap)
(define-key map "x" 'notmuch-bury-or-kill-this-buffer)
(define-key map (kbd "<DEL>") 'notmuch-search-scroll-down)
(define-key map (kbd "DEL") 'notmuch-search-scroll-down)
(define-key map "b" 'notmuch-search-scroll-down)
(define-key map " " 'notmuch-search-scroll-up)
(define-key map "<" 'notmuch-search-first-thread)
@ -232,7 +232,7 @@ there will be called at other points of notmuch execution."
(defvar notmuch-search-target-thread)
(defvar notmuch-search-target-line)
(defvar notmuch-search-disjunctive-regexp "\\<[oO][rR]\\>")
(defvar notmuch-search-disjunctive-regexp "\\<[oO][rR]\\>")
;;; Movement
@ -950,40 +950,39 @@ See `notmuch-tag' for information on the format of TAG-CHANGES."
"Read a notmuch-query from the minibuffer with completion.
PROMPT is the string to prompt with."
(let*
((all-tags
(mapcar (lambda (tag) (notmuch-escape-boolean-term tag))
(process-lines notmuch-command "search" "--output=tags" "*")))
(completions
(append (list "folder:" "path:" "thread:" "id:" "date:" "from:" "to:"
"subject:" "attachment:")
(mapcar (lambda (tag) (concat "tag:" tag)) all-tags)
(mapcar (lambda (tag) (concat "is:" tag)) all-tags)
(mapcar (lambda (mimetype) (concat "mimetype:" mimetype))
(mailcap-mime-types)))))
(let ((keymap (copy-keymap minibuffer-local-map))
(current-query (cl-case major-mode
(notmuch-search-mode (notmuch-search-get-query))
(notmuch-show-mode (notmuch-show-get-query))
(notmuch-tree-mode (notmuch-tree-get-query))))
(minibuffer-completion-table
(completion-table-dynamic
(lambda (string)
;; generate a list of possible completions for the current input
(cond
;; this ugly regexp is used to get the last word of the input
;; possibly preceded by a '('
((string-match "\\(^\\|.* (?\\)\\([^ ]*\\)$" string)
(mapcar (lambda (compl)
(concat (match-string-no-properties 1 string) compl))
(all-completions (match-string-no-properties 2 string)
completions)))
(t (list string)))))))
;; this was simpler than convincing completing-read to accept spaces:
(define-key keymap (kbd "TAB") 'minibuffer-complete)
(let ((history-delete-duplicates t))
(read-from-minibuffer prompt nil keymap nil
'notmuch-search-history current-query nil)))))
(let* ((all-tags
(mapcar (lambda (tag) (notmuch-escape-boolean-term tag))
(process-lines notmuch-command "search" "--output=tags" "*")))
(completions
(append (list "folder:" "path:" "thread:" "id:" "date:" "from:" "to:"
"subject:" "attachment:")
(mapcar (lambda (tag) (concat "tag:" tag)) all-tags)
(mapcar (lambda (tag) (concat "is:" tag)) all-tags)
(mapcar (lambda (mimetype) (concat "mimetype:" mimetype))
(mailcap-mime-types))))
(keymap (copy-keymap minibuffer-local-map))
(current-query (cl-case major-mode
(notmuch-search-mode (notmuch-search-get-query))
(notmuch-show-mode (notmuch-show-get-query))
(notmuch-tree-mode (notmuch-tree-get-query))))
(minibuffer-completion-table
(completion-table-dynamic
(lambda (string)
;; Generate a list of possible completions for the current input.
(cond
;; This ugly regexp is used to get the last word of the input
;; possibly preceded by a '('.
((string-match "\\(^\\|.* (?\\)\\([^ ]*\\)$" string)
(mapcar (lambda (compl)
(concat (match-string-no-properties 1 string) compl))
(all-completions (match-string-no-properties 2 string)
completions)))
(t (list string)))))))
;; This was simpler than convincing completing-read to accept spaces:
(define-key keymap (kbd "TAB") 'minibuffer-complete)
(let ((history-delete-duplicates t))
(read-from-minibuffer prompt nil keymap nil
'notmuch-search-history current-query nil))))
(defun notmuch-search-get-query ()
"Return the current query in this search buffer."
@ -1042,12 +1041,12 @@ the configured default sort order."
(if oldest-first
"--sort=oldest-first"
"--sort=newest-first")
query))
;; Use a scratch buffer to accumulate partial output.
;; This buffer will be killed by the sentinel, which
;; should be called no matter how the process dies.
(parse-buf (generate-new-buffer " *notmuch search parse*")))
(process-put proc 'parse-buf parse-buf)
query)))
;; Use a scratch buffer to accumulate partial output.
;; This buffer will be killed by the sentinel, which
;; should be called no matter how the process dies.
(process-put proc 'parse-buf
(generate-new-buffer " *notmuch search parse*"))
(set-process-filter proc 'notmuch-search-process-filter)
(set-process-query-on-exit-flag proc nil))))
(run-hooks 'notmuch-search-hook)))