01/01: ui: 'relevance' connects regexps with a logical and.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit d2cdef65605b9e14bfa02c3bf1612ab6b62f4a89
Author: zimoun <address@hidden>
Date:   Wed Sep 18 17:57:57 2019 +0200

    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 <address@hidden>
---
 guix/ui.scm  | 48 ++++++++++++++++++++++++------------------------
 tests/ui.scm |  5 ++++-
 2 files changed, 28 insertions(+), 25 deletions(-)

diff --git a/guix/ui.scm b/guix/ui.scm
index 7920335..4be31db 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -13,6 +13,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2019 Chris Marusich <address@hidden>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <address@hidden>
+;;; Copyright © 2019 Simon Tournier <address@hidden>
 ;;;
 ;;; 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 2138e23..d8573e8 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")