diff options
| -rw-r--r-- | Makefile | 3 | ||||
| -rw-r--r-- | piem-lei.el | 147 | ||||
| -rw-r--r-- | tests/piem-lei-tests.el | 74 | ||||
| -rw-r--r-- | tests/piem-tests.el | 1 |
4 files changed, 224 insertions, 1 deletions
@@ -6,7 +6,7 @@ BATCH = $(EMACS) --batch -Q -L . -L tests EL = piem.el piem-b4.el piem-elfeed.el piem-eww.el piem-gnus.el \ piem-lei.el piem-maildir.el piem-notmuch.el piem-rmail.el \ - tests/piem-rmail-tests.el tests/piem-tests.el + tests/piem-lei-tests.el tests/piem-rmail-tests.el tests/piem-tests.el ELC = $(EL:.el=.elc) all: compile Documentation/piem.info piem-autoloads.el @@ -40,6 +40,7 @@ piem-maildir.elc: piem-maildir.el piem-notmuch.elc: piem-notmuch.el piem.elc piem-rmail.elc: piem-rmail.el piem.elc piem.elc: piem.el piem-maildir.elc +tests/piem-lei-tests.elc: tests/piem-lei-tests.el piem-lei.elc tests/piem-rmail-tests.elc: tests/piem-rmail-tests.el piem-rmail.elc tests/piem-tests.elc: tests/piem-tests.el piem.elc diff --git a/piem-lei.el b/piem-lei.el index 12ccd87..1b74421 100644 --- a/piem-lei.el +++ b/piem-lei.el @@ -21,6 +21,8 @@ ;;; Code: +(require 'cl-lib) +(require 'iso8601) (require 'json) (require 'message) (require 'piem) @@ -226,5 +228,150 @@ line." (setq buffer-read-only t) (setq-local line-move-visual t)) + +;;;;; Threading + +;; The approach here tries to loosely follow what is in public-inbox's +;; SearchThread.pm, which in turn is a modified version of the +;; algorithm described at <https://www.jwz.org/doc/threading.html>. + +(cl-defstruct piem-lei-msg mid parent children time ghost) + +(defun piem-lei-query--add-child (parent child) + (let ((mid-parent (piem-lei-msg-mid parent)) + (mid-child (piem-lei-msg-mid child))) + (when (equal mid-parent mid-child) + (error "Parent and child have same message ID: %s" + mid-parent)) + (when-let ((parent-old (piem-lei-msg-parent child))) + (setf (piem-lei-msg-children parent-old) + (delq child (piem-lei-msg-children parent-old)))) + (push child (piem-lei-msg-children parent)) + (setf (piem-lei-msg-parent child) parent))) + +(defun piem-lei-query--has-descendant (msg1 msg2) + "Is MSG2 a descendant of MSG1?" + (let ((msg1-mid (piem-lei-msg-mid msg1)) + seen) + (catch 'stop + (while msg2 + (let ((msg2-mid (piem-lei-msg-mid msg2))) + (when (or (equal msg1-mid msg2-mid) + (member msg2 seen)) + (throw 'stop t)) + (push msg2-mid seen)) + (setq msg2 (piem-lei-msg-parent msg2))) + nil))) + +(defun piem-lei-query--thread (records) + "Thread messages in RECORDS. + +RECORDS is a list of alists with information from `lei q'. This +information is used to construct, link, and order `piem-lei-msg' +objects. + +Return a list with a `piem-lei-msg' object for each root." + (let ((thread (make-hash-table :test #'equal))) + (dolist (record records) + (let ((mid (cdr (assq 'm record)))) + (puthash mid + (make-piem-lei-msg + :mid mid :time (cdr (assq 'time record))) + thread))) + (dolist (record (sort (copy-sequence records) + (lambda (a b) + (time-less-p (cdr (assq 'time a)) + (cdr (assq 'time b)))))) + (let ((msg-prev nil) + (msg-cur (gethash (cdr (assq 'm record)) thread))) + (dolist (ref (cdr (assq 'refs record))) + (let ((msg (or (gethash ref thread) + (puthash ref + (make-piem-lei-msg :mid ref :ghost t) + thread)))) + (when (and msg-prev + (not (piem-lei-msg-parent msg)) + (not (piem-lei-query--has-descendant msg msg-prev))) + (piem-lei-query--add-child msg-prev msg)) + (setq msg-prev msg))) + (when (and msg-prev + (not (piem-lei-query--has-descendant msg-cur msg-prev))) + (piem-lei-query--add-child msg-prev msg-cur)))) + (let (roots) + (maphash + (lambda (_ v) + (setf (piem-lei-msg-children v) + (sort (piem-lei-msg-children v) + (lambda (a b) + (time-less-p (piem-lei-msg-time a) + (piem-lei-msg-time b))))) + (unless (piem-lei-msg-parent v) + (push v roots))) + thread) + (nreverse roots)))) + +(defun piem-lei-query--format-thread-marker (level) + (if (= level 0) + "" + (concat (make-string (* 2 (1- level)) ?\s) + "` "))) + +(defun piem-lei-query--slurp (args) + (with-temp-buffer + (apply #'call-process "lei" nil '(t nil) nil + "q" "--format=ldjson" args) + (goto-char (point-min)) + (let (items) + (while (not (eobp)) + (let ((item (piem-lei-query--read-json-item))) + (push (cons 'time (encode-time + (iso8601-parse (cdr (assq 'dt item))))) + item) + (push (cons (cdr (assq 'm item)) item) items)) + (forward-line)) + (nreverse items)))) + +(defun piem-lei-query-thread (mid) + "Show thread containing message MID." + (interactive + (list (or (piem-lei-query-get-mid) + (read-string "Message ID: " nil nil (piem-mid))))) + (let* ((records (piem-lei-query--slurp + (list "--threads" (concat "m:" mid)))) + (msgs (piem-lei-query--thread records)) + depths) + (with-current-buffer (get-buffer-create "*lei-thread*") + (let ((inhibit-read-only t)) + (erase-buffer) + (while msgs + (let* ((msg (pop msgs)) + (mid-msg (piem-lei-msg-mid msg)) + (children (piem-lei-msg-children msg)) + (depth (1+ (or (cdr (assoc (piem-lei-msg-parent msg) depths)) + -1)))) + (when children + (setq msgs (append children msgs))) + (push (cons msg depth) depths) + (if (not (piem-lei-msg-ghost msg)) + (let ((data (cdr (assoc mid-msg records)))) + (insert + (piem-lei-query--format-date data) " " + (piem-lei-query--format-thread-marker depth) + (let ((from (car (cdr (assq 'f data))))) + (or (car from) (cadr from))) + (concat " " + (cdr (assq 's data)))) + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'piem-lei-query-result data))) + (insert (make-string 17 ?\s) ; Date alignment. + (piem-lei-query--format-thread-marker depth) + (concat " <" mid-msg ">"))) + (insert ?\n))) + (insert "End of lei-q results")) + (goto-char (point-min)) + (piem-lei-query-mode) + (pop-to-buffer-same-window (current-buffer))))) + ;;; piem-lei.el ends here (provide 'piem-lei) diff --git a/tests/piem-lei-tests.el b/tests/piem-lei-tests.el new file mode 100644 index 0000000..e20c62f --- /dev/null +++ b/tests/piem-lei-tests.el @@ -0,0 +1,74 @@ +;;; piem-lei-tests.el --- tests for piem-lei -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 all contributors <piem@inbox.kyleam.com> + +;; Author: Kyle Meyer <kyle@kyleam.com> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'piem-lei) + +(ert-deftest piem-lei-query--add-child () + (should-error + (piem-lei-query--add-child + (make-piem-lei-msg :mid "m1") + (make-piem-lei-msg :mid "m1"))) + (let ((m1 (make-piem-lei-msg :mid "m1")) + (m2 (make-piem-lei-msg :mid "m2"))) + (piem-lei-query--add-child m1 m2) + (should (equal (piem-lei-msg-parent m2) m1)) + (should (equal (piem-lei-msg-children m1) (list m2)))) + (let ((m1 (make-piem-lei-msg :mid "m1")) + (m2 (make-piem-lei-msg :mid "m2")) + (m3 (make-piem-lei-msg :mid "m3")) + (m4 (make-piem-lei-msg :mid "m4"))) + (piem-lei-query--add-child m1 m2) + (piem-lei-query--add-child m1 m4) + (piem-lei-query--add-child m3 m2) + (should (equal (piem-lei-msg-parent m2) m3)) + (should (equal (piem-lei-msg-children m1) (list m4))) + (should (equal (piem-lei-msg-children m3) (list m2))))) + +(ert-deftest piem-lei-query--has-descendant () + (let ((m1 (make-piem-lei-msg :mid "m1")) + (m2 (make-piem-lei-msg :mid "m2"))) + (should-not + (piem-lei-query--has-descendant m1 m2)) + (should-not + (piem-lei-query--has-descendant m2 m1))) + (let ((m1 (make-piem-lei-msg :mid "m1"))) + (should (piem-lei-query--has-descendant m1 m1))) + (let ((m1 (make-piem-lei-msg :mid "m1")) + (m2 (make-piem-lei-msg :mid "m2"))) + (piem-lei-query--add-child m1 m2) + (should (piem-lei-query--has-descendant m1 m2)) + (should-not + (piem-lei-query--has-descendant m2 m1))) + (let ((m1 (make-piem-lei-msg :mid "m1")) + (m2 (make-piem-lei-msg :mid "m2")) + (m3 (make-piem-lei-msg :mid "m3"))) + (piem-lei-query--add-child m1 m2) + (piem-lei-query--add-child m2 m3) + (should (piem-lei-query--has-descendant m1 m2)) + (should (piem-lei-query--has-descendant m1 m3)) + (should (piem-lei-query--has-descendant m2 m3)) + (should-not (piem-lei-query--has-descendant m2 m1)) + (should-not (piem-lei-query--has-descendant m3 m2)) + (should-not (piem-lei-query--has-descendant m3 m1)))) + +(provide 'piem-lei-tests) +;;; piem-lei-tests.el ends here diff --git a/tests/piem-tests.el b/tests/piem-tests.el index 5f01a5e..91beb9a 100644 --- a/tests/piem-tests.el +++ b/tests/piem-tests.el @@ -21,6 +21,7 @@ (require 'ert) (require 'piem) +(require 'piem-lei-tests) (require 'piem-rmail-tests) (ert-deftest piem-message-link-re () |