summaryrefslogtreecommitdiff
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)
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 7920335928f..4be31db0474 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -13,6 +13,7 @@
13;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> 13;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
14;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com> 14;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
15;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> 15;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
16;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
16;;; 17;;;
17;;; This file is part of GNU Guix. 18;;; This file is part of GNU Guix.
18;;; 19;;;
@@ -1281,33 +1282,32 @@ weight of this field in the final score.
1281 1282
1282A score of zero means that OBJ does not match any of REGEXPS. The higher the 1283A score of zero means that OBJ does not match any of REGEXPS. The higher the
1283score, the more relevant OBJ is to REGEXPS." 1284score, the more relevant OBJ is to REGEXPS."
1284 (define (score str) 1285 (define (score regexp str)
1285 (define scores 1286 (fold-matches regexp str 0
1286 (map (lambda (regexp) 1287 (lambda (m score)
1287 (fold-matches regexp str 0 1288 (+ score
1288 (lambda (m score) 1289 (if (string=? (match:substring m) str)
1289 (+ score 1290 5 ;exact match
1290 (if (string=? (match:substring m) str) 1291 1)))))
1291 5 ;exact match 1292
1292 1))))) 1293 (define (regexp->score regexp)
1293 regexps)) 1294 (let ((score-regexp (lambda (str) (score regexp str))))
1294 1295 (fold (lambda (metric relevance)
1296 (match metric
1297 ((field . weight)
1298 (match (field obj)
1299 (#f relevance)
1300 ((? string? str)
1301 (+ relevance (* (score-regexp str) weight)))
1302 ((lst ...)
1303 (+ relevance (* weight (apply + (map score-regexp lst)))))))))
1304 0 metrics)))
1305
1306 (let ((scores (map regexp->score regexps)))
1295 ;; Return zero if one of REGEXPS doesn't match. 1307 ;; Return zero if one of REGEXPS doesn't match.
1296 (if (any zero? scores) 1308 (if (any zero? scores)
1297 0 1309 0
1298 (reduce + 0 scores))) 1310 (reduce + 0 scores))))
1299
1300 (fold (lambda (metric relevance)
1301 (match metric
1302 ((field . weight)
1303 (match (field obj)
1304 (#f relevance)
1305 ((? string? str)
1306 (+ relevance (* (score str) weight)))
1307 ((lst ...)
1308 (+ relevance (* weight (apply + (map score lst)))))))))
1309 0
1310 metrics))
1311 1311
1312(define %package-metrics 1312(define %package-metrics
1313 ;; Metrics used to compute the "relevance score" of a package against a set 1313 ;; Metrics used to compute the "relevance score" of a package against a set
diff --git a/tests/ui.scm b/tests/ui.scm
index 2138e23369b..d8573e88d80 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -267,6 +267,7 @@ Second line" 24))
267 (gcrypt (specification->package "guile-gcrypt")) 267 (gcrypt (specification->package "guile-gcrypt"))
268 (go (specification->package "go")) 268 (go (specification->package "go"))
269 (gnugo (specification->package "gnugo")) 269 (gnugo (specification->package "gnugo"))
270 (libb2 (specification->package "libb2"))
270 (rx (cut make-regexp <> regexp/icase)) 271 (rx (cut make-regexp <> regexp/icase))
271 (>0 (cut > <> 0)) 272 (>0 (cut > <> 0))
272 (=0 zero?)) 273 (=0 zero?))
@@ -283,6 +284,8 @@ Second line" 24))
283 (=0 (package-relevance go 284 (=0 (package-relevance go
284 (map rx '("go" "game")))) 285 (map rx '("go" "game"))))
285 (>0 (package-relevance gnugo 286 (>0 (package-relevance gnugo
286 (map rx '("go" "game"))))))) 287 (map rx '("go" "game"))))
288 (>0 (package-relevance libb2
289 (map rx '("crypto" "library")))))))
287 290
288(test-end "ui") 291(test-end "ui")