summary refs log tree commit diff
diff options
context:
space:
mode:
authorzimoun <zimon.toutoune@gmail.com>2019-09-18 17:57:57 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-19 23:24:04 +0200
commitd2cdef65605b9e14bfa02c3bf1612ab6b62f4a89 (patch)
tree6868972815e7deca295565a2e84efad7783604ae
parent6ec872231fdf746bd6e11b97f8a6b3a23498806c (diff)
downloadguix-d2cdef65605b9e14bfa02c3bf1612ab6b62f4a89.tar.gz
ui: 'relevance' connects regexps with a logical and.
Fixes <https://bugs.gnu.org/36763>.
Previously, the logical and connecting the regexps did not output the expected
results (introduced in 8874faaaac665100a095ef25e39c9a389f5a397f).

* guix/ui.scm (relevance)
[score]: Change its arguments.
[regexp->score]: New procedure.
* tests/ui.scm ("package-relevance"): Add test.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r--guix/ui.scm48
-rw-r--r--tests/ui.scm5
2 files changed, 28 insertions, 25 deletions
diff --git a/guix/ui.scm b/guix/ui.scm
index 7920335928..4be31db047 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -13,6 +13,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1281,33 +1282,32 @@ weight of this field in the final score.
 
 A score of zero means that OBJ does not match any of REGEXPS.  The higher the
 score, the more relevant OBJ is to REGEXPS."
-  (define (score str)
-    (define scores
-      (map (lambda (regexp)
-             (fold-matches regexp str 0
-                           (lambda (m score)
-                             (+ score
-                                (if (string=? (match:substring m) str)
-                                    5             ;exact match
-                                    1)))))
-           regexps))
-
+  (define (score regexp str)
+    (fold-matches regexp str 0
+                  (lambda (m score)
+                    (+ score
+                       (if (string=? (match:substring m) str)
+                           5             ;exact match
+                           1)))))
+
+  (define (regexp->score regexp)
+    (let ((score-regexp (lambda (str) (score regexp str))))
+      (fold (lambda (metric relevance)
+              (match metric
+                ((field . weight)
+                 (match (field obj)
+                   (#f  relevance)
+                   ((? string? str)
+                    (+ relevance (* (score-regexp str) weight)))
+                   ((lst ...)
+                    (+ relevance (* weight (apply + (map score-regexp lst)))))))))
+            0 metrics)))
+
+  (let ((scores (map regexp->score regexps)))
     ;; Return zero if one of REGEXPS doesn't match.
     (if (any zero? scores)
         0
-        (reduce + 0 scores)))
-
-  (fold (lambda (metric relevance)
-          (match metric
-            ((field . weight)
-             (match (field obj)
-               (#f  relevance)
-               ((? string? str)
-                (+ relevance (* (score str) weight)))
-               ((lst ...)
-                (+ relevance (* weight (apply + (map score lst)))))))))
-        0
-        metrics))
+        (reduce + 0 scores))))
 
 (define %package-metrics
   ;; Metrics used to compute the "relevance score" of a package against a set
diff --git a/tests/ui.scm b/tests/ui.scm
index 2138e23369..d8573e88d8 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -267,6 +267,7 @@ Second line" 24))
         (gcrypt (specification->package "guile-gcrypt"))
         (go     (specification->package "go"))
         (gnugo  (specification->package "gnugo"))
+        (libb2  (specification->package "libb2"))
         (rx     (cut make-regexp <> regexp/icase))
         (>0     (cut > <> 0))
         (=0     zero?))
@@ -283,6 +284,8 @@ Second line" 24))
          (=0 (package-relevance go
                                 (map rx '("go" "game"))))
          (>0 (package-relevance gnugo
-                                (map rx '("go" "game")))))))
+                                (map rx '("go" "game"))))
+         (>0 (package-relevance libb2
+                                (map rx '("crypto" "library")))))))
 
 (test-end "ui")