lei: Add command for viewing a thread

piem-lei-query presents a message-based overview.  In many cases the
caller will want to use that search result as a seed for finding the
associated thread.  Add a command that construct thread for a given
message.

The threading algorithm is based on public-inbox's.  Some details may
have been lost in translation, but I haven't spotted any differences
yet when doing side-by-side comparisons of output from
piem-lei-query-thread and public-inbox's web interface.  And testing
with a few ~100-message threads, the performance seems to be okay.

The appearance also follows public-inbox's, which I like.

Message-Id: <20210605211402.20304-7-kyle@kyleam.com>

4 files changed, 224 insertions, 1 deletions

diff --git a/Makefile b/Makefile
index dac422b..b8d9fe6 100644
--- a/Makefile
+++ b/Makefile
@@ -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 ()