xapian: Support generation of SXML snippets.

* xapian/xapian.scm: Import (htmlprag).
(mset-sxml-snippet): New public function.

1 files changed, 33 insertions, 1 deletions

diff --git a/xapian/xapian.scm b/xapian/xapian.scm
index f13365e..650c401 100644
--- a/xapian/xapian.scm
+++ b/xapian/xapian.scm
@@ -23,6 +23,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-26)
+  #:use-module (htmlprag)
   #:use-module (xapian wrap)
   #:export (xapian-open
             xapian-close
@@ -55,7 +56,8 @@
             mset-item-rank
             mset-item-weight
             mset-fold
-            mset-snippet))
+            mset-snippet
+            mset-sxml-snippet))
 
 (define xapian-open new-Database)
 (define xapian-close delete-Database)
@@ -241,3 +243,33 @@ for more details."
                              (get-flag MSet-SNIPPET-EMPTY-WITHOUT-MATCH empty-without-match?)
                              (get-flag MSet-SNIPPET-CJK-NGRAM cjk-ngram?))
                 highlight-start highlight-end omit))
+
+(define* (mset-sxml-snippet mset text #:key (length 500) (stemmer (make-stem "none"))
+                           (highlight-proc (lambda (text)
+                                             `(b ,text)))
+                           (omit "...") (background-model? #t) (exhaustive? #t)
+                           (empty-without-match? #t) (cjk-ngram? #t))
+  "Generate a snippet in SXML form from @var{text}.
+
+@var{highlight-proc} is a function that is passed the highlit text. It
+should return a SXML tree highlighting that text.
+
+Arguments @var{mset}, @var{length}, @var{stemmer}, @var{omit},
+@var{background-model?}, @var{exhaustive?}, @var{empty-without-match?}
+and @var{cjk-ngram?} are the same as in the @code{mset-snippet}
+function."
+  ;; mset-snippet returns serialized HTML. So, we reverse it with
+  ;; html->sxml.
+  (match (html->sxml (mset-snippet text mset))
+    (('*TOP* children ...)
+     (append-map (match-lambda
+                   ;; Apply highlight-proc if highlit text.
+                   (('b text)
+                    (highlight-proc text))
+                   ;; Add (br) if end of line.
+                   ((? (cut string-suffix? "\n" <>) text)
+                    (list (string-trim-right text #\newline)
+                          '(br)))
+                   ;; Else, return verbatim.
+                   (text text))
+                 children))))