diff options
| author | zimoun <zimon.toutoune@gmail.com> | 2019-09-18 17:57:57 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2019-09-19 23:24:04 +0200 |
| commit | d2cdef65605b9e14bfa02c3bf1612ab6b62f4a89 (patch) | |
| tree | 6868972815e7deca295565a2e84efad7783604ae | |
| parent | 6ec872231fdf746bd6e11b97f8a6b3a23498806c (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.scm | 48 | ||||
| -rw-r--r-- | tests/ui.scm | 5 |
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 | ||
| 1282 | A score of zero means that OBJ does not match any of REGEXPS. The higher the | 1283 | A score of zero means that OBJ does not match any of REGEXPS. The higher the |
| 1283 | score, the more relevant OBJ is to REGEXPS." | 1284 | score, 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") |
