From: "Ludovic Courtès" <ludo@gnu.org>
To: 36390@debbugs.gnu.org
Subject: [bug#36390] [PATCH 3/3] ui: Add 'display-search-results' and use it.
Date: Wed, 26 Jun 2019 10:59:04 +0200 [thread overview]
Message-ID: <20190626085904.3560-3-ludo@gnu.org> (raw)
In-Reply-To: <20190626085904.3560-1-ludo@gnu.org>
* guix/ui.scm (display-search-results): New procedure.
* guix/scripts/package.scm (find-packages-by-description): Remove
'unzip2' call and return a list of pairs.
(process-query): Change to use 'display-search-results'.
* guix/scripts/system/search.scm (find-service-types): Remove 'unzip2'
call and return a list of pairs.
(guix-system-search): Use 'display-search-results'.
---
guix/scripts/package.scm | 41 ++++++++++++----------------
guix/scripts/system/search.scm | 44 +++++++++++++-----------------
guix/ui.scm | 50 +++++++++++++++++++++++++++++++++-
3 files changed, 86 insertions(+), 49 deletions(-)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5751123525..7b277b63f1 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -26,6 +26,7 @@
(define-module (guix scripts package)
#:use-module (guix ui)
#:use-module ((guix status) #:select (with-status-verbosity))
+ #:use-module ((guix build syscalls) #:select (terminal-rows))
#:use-module (guix store)
#:use-module (guix grafts)
#:use-module (guix derivations)
@@ -178,9 +179,9 @@ hooks\" run when building the profile."
;;;
(define (find-packages-by-description regexps)
- "Return two values: the list of packages whose name, synopsis, description,
-or output matches at least one of REGEXPS sorted by relevance, and the list of
-relevance scores."
+ "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
@@ -189,19 +190,19 @@ relevance scores."
((? zero?)
result)
(score
- (cons (list package score)
+ (cons (cons package score)
result)))))
'())))
- (unzip2 (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)))))))))))
+ (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 entry transaction)
"Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
@@ -755,16 +756,10 @@ processed, #f otherwise."
(('query 'search rx) rx)
(_ #f))
opts))
- (regexps (map (cut make-regexp* <> regexp/icase) patterns)))
+ (regexps (map (cut make-regexp* <> regexp/icase) patterns))
+ (matches (find-packages-by-description regexps)))
(leave-on-EPIPE
- (let-values (((packages scores)
- (find-packages-by-description regexps)))
- (for-each (lambda (package score)
- (package->recutils package (current-output-port)
- #:extra-fields
- `((relevance . ,score))))
- packages
- scores)))
+ (display-search-results matches (current-output-port)))
#t))
(('show requested-name)
diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
index 955cdd1e95..5278062edd 100644
--- a/guix/scripts/system/search.scm
+++ b/guix/scripts/system/search.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
@@ -139,9 +139,8 @@ columns."
. 1)))
(define (find-service-types regexps)
- "Return two values: the list of service types whose name or description
-matches at least one of REGEXPS sorted by relevance, and the list of relevance
-scores."
+ "Return a list of service type/score pairs: service types whose name or
+description matches REGEXPS sorted by relevance, and their score."
(let ((matches (fold-service-types
(lambda (type result)
(match (relevance type regexps
@@ -149,30 +148,25 @@ scores."
((? zero?)
result)
(score
- (cons (list type score) result))))
+ (cons (cons type score) result))))
'())))
- (unzip2 (sort matches
- (lambda (m1 m2)
- (match m1
- ((type1 score1)
- (match m2
- ((type2 score2)
- (if (= score1 score2)
- (string>? (service-type-name* type1)
- (service-type-name* type2))
- (> score1 score2)))))))))))
+ (sort matches
+ (lambda (m1 m2)
+ (match m1
+ ((type1 . score1)
+ (match m2
+ ((type2 . score2)
+ (if (= score1 score2)
+ (string>? (service-type-name* type1)
+ (service-type-name* type2))
+ (> score1 score2))))))))))
\f
(define (guix-system-search . args)
(with-error-handling
- (let ((regexps (map (cut make-regexp* <> regexp/icase) args)))
+ (let* ((regexps (map (cut make-regexp* <> regexp/icase) args))
+ (matches (find-service-types regexps)))
(leave-on-EPIPE
- (let-values (((services scores)
- (find-service-types regexps)))
- (for-each (lambda (service score)
- (service-type->recutils service
- (current-output-port)
- #:extra-fields
- `((relevance . ,score))))
- services
- scores))))))
+ (display-search-results matches (current-output-port)
+ #:print service-type->recutils
+ #:command "guix system search")))))
diff --git a/guix/ui.scm b/guix/ui.scm
index d9dbe4a652..363ef36dcd 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -46,7 +46,8 @@
#:use-module (guix serialization)
#:use-module ((guix licenses) #:select (license? license-name))
#:use-module ((guix build syscalls)
- #:select (free-disk-space terminal-columns))
+ #:select (free-disk-space terminal-columns
+ terminal-rows))
#:use-module ((guix build utils)
;; XXX: All we need are the bindings related to
;; '&invoke-error'. However, to work around the bug described
@@ -106,8 +107,11 @@
string->recutils
package->recutils
package-specification->name+version+output
+
relevance
package-relevance
+ display-search-results
+
string->generations
string->duration
matching-generations
@@ -1246,6 +1250,11 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit."
extra-fields)
(newline port))
+\f
+;;;
+;;; Searching.
+;;;
+
(define (relevance obj regexps metrics)
"Compute a \"relevance score\" for OBJ as a function of its number of
matches of REGEXPS and accordingly to METRICS. METRICS is list of
@@ -1315,6 +1324,45 @@ score, the more relevant OBJ is to REGEXPS."
zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics))
+(define* (display-search-results matches port
+ #:key
+ (command "guix search")
+ (print package->recutils))
+ "Display MATCHES, a list of object/score pairs, by calling PRINT on each of
+them. If PORT is a terminal, print at most a full screen of results."
+ (define first-line
+ (port-line port))
+
+ (define max-rows
+ (and first-line (isatty? port)
+ (terminal-rows port)))
+
+ (define (line-count str)
+ (string-count str #\newline))
+
+ (let loop ((matches matches))
+ (match matches
+ (((package . score) rest ...)
+ (let ((text (call-with-output-string
+ (lambda (port)
+ (print package port
+ #:extra-fields
+ `((relevance . ,score)))))))
+ (if (and max-rows
+ (> (port-line port) first-line) ;print at least one result
+ (> (+ 4 (line-count text) (port-line port))
+ max-rows))
+ (unless (null? rest)
+ (display-hint (format #f (G_ "Run @code{~a ... | less} \
+to view all the results.")
+ command)))
+ (begin
+ (display text port)
+ (loop rest)))))
+ (()
+ #t))))
+
+\f
(define (string->generations str)
"Return the list of generations matching a pattern in STR. This function
accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
--
2.22.0
next prev parent reply other threads:[~2019-06-26 9:00 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-06-26 8:43 [bug#36390] [PATCH 0/3] Improve 'guix search' relevance and display Ludovic Courtès
2019-06-26 8:59 ` [bug#36390] [PATCH 1/3] ui: 'relevance' considers regexps connected with a logical and Ludovic Courtès
2019-06-26 8:59 ` [bug#36390] [PATCH 2/3] syscalls: Add 'terminal-rows' Ludovic Courtès
2019-06-26 8:59 ` Ludovic Courtès [this message]
2019-06-26 9:57 ` [bug#36390] [PATCH 0/3] Improve 'guix search' relevance and display Ricardo Wurmus
2019-06-27 9:19 ` bug#36390: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190626085904.3560-3-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=36390@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.