From 7b4c903e337d004677ed22b13ba74c0e28dc302d Mon Sep 17 00:00:00 2001
From: Arun Isaac <arunisaac@systemreboot.net>
Date: Fri, 28 Feb 2020 02:11:50 +0530
Subject: gnu: Use xapian index for package search.

* gnu/packages.scm (search-package-index): New function.
* guix/scripts/package.scm (find-packages-by-description): Search using the
xapian package index if search patterns are literal strings. Else, search
using fold-packages.
---
 gnu/packages.scm         | 17 ++++++++++++++-
 guix/scripts/package.scm | 57 ++++++++++++++++++++++++++++--------------------
 2 files changed, 49 insertions(+), 25 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index e91753e2a8..5b5b29bf84 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -67,7 +67,8 @@
             specifications->manifest
 
             generate-package-cache
-            generate-package-search-index))
+            generate-package-search-index
+            search-package-index))
 
 ;;; Commentary:
 ;;;
@@ -453,6 +454,20 @@ reducing the memory footprint."
 
   db-path)
 
+(define (search-package-index profile querystring)
+  (let ((offset 0)
+        (pagesize 10))
+    (call-with-database (string-append profile %package-search-index)
+      (lambda (db)
+        (let ((query (parse-query querystring #:stemmer (make-stem "en"))))
+          (mset-fold (lambda (item result)
+                       (match (find-packages-by-name
+                               (document-data (mset-item-document item)))
+                         ((package _ ...)
+                          (append result `((,package . ,(mset-item-weight item)))))))
+                     '()
+                     (enquire-mset (enquire db query) offset pagesize)))))))
+
 
 (define %sigint-prompt
   ;; The prompt to jump to upon SIGINT.
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1cb0d382bf..6a3b9002dd 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -178,31 +179,40 @@ hooks\" run when building the profile."
 ;;; Package specifications.
 ;;;
 
-(define (find-packages-by-description regexps)
+(define (find-packages-by-description patterns)
   "Return a list of pairs: packages whose name, synopsis, description,
 or output matches at least one of REGEXPS sorted by relevance, and its
 non-zero relevance score."
-  (let ((matches (fold-packages (lambda (package result)
-                                  (if (package-superseded package)
-                                      result
-                                      (match (package-relevance package
-                                                                regexps)
-                                        ((? zero?)
-                                         result)
-                                        (score
-                                         (cons (cons package score)
-                                               result)))))
-                                '())))
-    (sort matches
-          (lambda (m1 m2)
-            (match m1
-              ((package1 . score1)
-               (match m2
-                 ((package2 . score2)
-                  (if (= score1 score2)
-                      (string>? (package-full-name package1)
-                                (package-full-name package2))
-                      (> score1 score2))))))))))
+  (define (regexp? str)
+    (string-any
+     (char-set #\. #\[ #\{ #\} #\( #\) #\\ #\* #\+ #\? #\| #\^ #\$)
+     str))
+
+  (if (and (current-profile)
+           (not (any regexp? patterns)))
+      (search-package-index (current-profile) (string-join patterns " "))
+      (let* ((regexps (map (cut make-regexp* <> regexp/icase) patterns))
+             (matches (fold-packages (lambda (package result)
+                                       (if (package-superseded package)
+                                           result
+                                           (match (package-relevance package
+                                                                     regexps)
+                                             ((? zero?)
+                                              result)
+                                             (score
+                                              (cons (cons package score)
+                                                    result)))))
+                                     '())))
+        (sort matches
+              (lambda (m1 m2)
+                (match m1
+                  ((package1 . score1)
+                   (match m2
+                     ((package2 . score2)
+                      (if (= score1 score2)
+                          (string>? (package-full-name package1)
+                                    (package-full-name package2))
+                          (> score1 score2)))))))))))
 
 (define (transaction-upgrade-entry store entry transaction)
   "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
@@ -777,8 +787,7 @@ processed, #f otherwise."
                                       (('query 'search rx) rx)
                                       (_                   #f))
                                     opts))
-              (regexps  (map (cut make-regexp* <> regexp/icase) patterns))
-              (matches  (find-packages-by-description regexps)))
+              (matches  (find-packages-by-description patterns)))
          (leave-on-EPIPE
           (display-search-results matches (current-output-port)))
          #t))
-- 
cgit v1.2.3