From 6037051f49ab5f96b406461490dba56faa2a5f35 Mon Sep 17 00:00:00 2001 From: Andrew G Cohen Date: Wed, 23 Sep 2020 19:47:15 +0800 Subject: [PATCH] Improve mark handling in gnus nnselect * lisp/gnus/nnselect.el (numbers-by-group, nnselect-request-update-info, nnselect-push-info): Handle all three mark types ('tuple, 'range, 'list) and general speedups. --- lisp/gnus/nnselect.el | 217 +++++++++++++++++++++++++++--------------- 1 file changed, 142 insertions(+), 75 deletions(-) diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index c6f2ffae9c6..8cd658100fb 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -203,11 +203,22 @@ as `(keyfunc member)' and the corresponding element is just (nnselect-categorize ,articles 'nnselect-article-group 'nnselect-article-id))) -(define-inline numbers-by-group (articles) +(define-inline numbers-by-group (articles &optional type) (inline-quote - (nnselect-categorize - ,articles 'nnselect-article-group 'nnselect-article-number))) - + (cond + ((eq ,type 'range) + (nnselect-categorize (gnus-uncompress-range ,articles) + 'nnselect-article-group 'nnselect-article-number)) + ((eq ,type 'tuple) + (nnselect-categorize ,articles + #'(lambda (elem) + (nnselect-article-group (car elem))) + #'(lambda (elem) + (cons (nnselect-article-number + (car elem)) (cdr elem))))) + (t + (nnselect-categorize ,articles + 'nnselect-article-group 'nnselect-article-number))))) (defmacro nnselect-add-prefix (group) "Ensures that the GROUP has an nnselect prefix." @@ -504,15 +515,15 @@ If this variable is nil, or if the provided function returns nil, (list (car artgroup) (gnus-compress-sequence (sort (cdr artgroup) '<)) action marks)) - (numbers-by-group - (gnus-uncompress-range range))))) + (numbers-by-group range 'range)))) actions) 'car 'cdr))) (deffoo nnselect-request-update-info (group info &optional _server) - (let* ((group (nnselect-add-prefix group)) - (gnus-newsgroup-selection (or gnus-newsgroup-selection - (nnselect-get-artlist group)))) + (let* ((group (nnselect-add-prefix group)) + (gnus-newsgroup-selection + (or gnus-newsgroup-selection (nnselect-get-artlist group))) + newmarks) (gnus-info-set-marks info nil) (setf (gnus-info-read info) nil) (pcase-dolist (`(,artgroup . ,nartids) @@ -520,30 +531,56 @@ If this variable is nil, or if the provided function returns nil, (number-sequence 1 (nnselect-artlist-length gnus-newsgroup-selection)))) (let* ((gnus-newsgroup-active nil) - (artids (cl-sort nartids '< :key 'car)) + (artids (cl-sort nartids #'< :key 'car)) (group-info (gnus-get-info artgroup)) (marks (gnus-info-marks group-info)) (unread (gnus-uncompress-sequence (gnus-range-difference (gnus-active artgroup) (gnus-info-read group-info))))) - (gnus-atomic-progn - (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-info-read info) - (delq nil - (mapcar - #'(lambda (art) - (unless (memq (cdr art) unread) (car art))) - artids)))) - (pcase-dolist (`(,type . ,range) marks) - (setq range (gnus-uncompress-sequence range)) - (gnus-add-marked-articles - group type - (delq nil - (mapcar - #'(lambda (art) - (when (memq (cdr art) range) - (car art))) artids))))))) + (setf (gnus-info-read info) + (gnus-add-to-range + (gnus-info-read info) + (delq nil (mapcar + #'(lambda (art) + (unless (memq (cdr art) unread) (car art))) + artids)))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (delq nil + (cond + ((eq mark-type 'tuple) + (mapcar + #'(lambda (id) + (let (mark) + (when + (setq mark (assq (cdr id) mark-list)) + (cons (car id) (cdr mark))))) + artids)) + (t + (setq mark-list + (gnus-uncompress-range mark-list)) + (mapcar + #'(lambda (id) + (when (memq (cdr id) mark-list) + (car id))) artids))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) + + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence mark-list))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) + + (gnus-info-set-marks info newmarks) (gnus-set-active group (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))) @@ -769,42 +806,61 @@ article came from is also searched." "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) (select-reads (numbers-by-group - (gnus-uncompress-range - (gnus-info-read (gnus-get-info group))))) + (gnus-info-read (gnus-get-info group)) 'range)) (select-unseen (numbers-by-group gnus-newsgroup-unseen)) - (gnus-newsgroup-active nil) - mark-list type-list) + (gnus-newsgroup-active nil) mark-list) + ;; collect the set of marked article lists categorized by + ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) - (when (setq type-list - (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) - (push (cons type - (numbers-by-group - (gnus-uncompress-range type-list))) mark-list))) + (let (type-list) + (when (setq type-list + (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) + (push (cons + type + (numbers-by-group type-list (gnus-article-mark-to-type type))) + mark-list)))) + ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) (numbers-by-group gnus-newsgroup-articles)) (let* ((group-info (gnus-get-info artgroup)) (old-unread (gnus-list-of-unread-articles artgroup)) - newmarked) + newmarked delta-marks) (when group-info + ;; iterate over mark lists for this group (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) - (let ((select-type - (sort - (cdr (assoc artgroup (alist-get type mark-list))) - '<)) list) - (setq list - (gnus-uncompress-range - (gnus-add-to-range - (gnus-remove-from-range - (alist-get type (gnus-info-marks group-info)) - artlist) - select-type))) - - (when list - ;; Get rid of the entries of the articles that have the - ;; default score. - (when (and (eq type 'score) - gnus-save-score - list) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. + (when (and (gnus-check-backend-function + 'request-set-mark artgroup) + (not (gnus-article-unpropagatable-p type))) + (let* ((old (gnus-list-range-intersection + artlist + (alist-get type (gnus-info-marks group-info)))) + (del (gnus-remove-from-range (copy-tree old) list)) + (add (gnus-remove-from-range (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (gnus-sorted-range-intersection + (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) (let* ((arts list) (prev (cons nil list)) (all prev)) @@ -814,30 +870,41 @@ article came from is also searched." (setcdr prev (cdr arts)) (setq prev arts)) (setq arts (cdr arts))) - (setq list (cdr all))))) - - (when (or (eq (gnus-article-mark-to-type type) 'list) - (eq (gnus-article-mark-to-type type) 'range)) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure (setq list - (gnus-compress-sequence (sort list '<) t))) - - ;; When exiting the group, everything that's previously been - ;; unseen is now seen. - (when (eq type 'seen) - (setq list (gnus-range-add - list (cdr (assoc artgroup select-unseen))))) + (sort (map-merge + 'list list + (alist-get type (gnus-info-marks group-info))) + (lambda (elt1 elt2) + (< (car elt1) (car elt2)))))) + (t + (setq list + (gnus-compress-sequence + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence + (alist-get type (gnus-info-marks group-info))) + artlist) + (sort list #'<)) t))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (gnus-range-add + list (cdr (assoc artgroup select-unseen)))))) (when (or list (eq type 'unexist)) - (push (cons type list) newmarked)))) + (push (cons type list) newmarked)))) ;; end of mark-type loop - (gnus-atomic-progn - ;; Enter these new marks into the info of the group. - (if (nthcdr 3 group-info) - (setcar (nthcdr 3 group-info) newmarked) - ;; Add the marks lists to the end of the info. - (when newmarked - (setcdr (nthcdr 2 group-info) (list newmarked)))) + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) ;; Cut off the end of the info if there's nothing else there. (let ((i 5)) (while (and (> i 2) -- 2.39.2