ui: Add 'display-search-results' and use it.
* 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'.
This commit is contained in:
Ludovic Courtès
parent
4593f5a654
commit
4311cf965c
|
|
@ -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
|
||||
(sort matches
|
||||
(lambda (m1 m2)
|
||||
(match m1
|
||||
((package1 score1)
|
||||
((package1 . score1)
|
||||
(match m2
|
||||
((package2 score2)
|
||||
((package2 . score2)
|
||||
(if (= score1 score2)
|
||||
(string>? (package-full-name package1)
|
||||
(package-full-name package2))
|
||||
(> score1 score2)))))))))))
|
||||
(> 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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(sort matches
|
||||
(lambda (m1 m2)
|
||||
(match m1
|
||||
((type1 score1)
|
||||
((type1 . score1)
|
||||
(match m2
|
||||
((type2 score2)
|
||||
((type2 . score2)
|
||||
(if (= score1 score2)
|
||||
(string>? (service-type-name* type1)
|
||||
(service-type-name* type2))
|
||||
(> score1 score2)))))))))))
|
||||
(> score1 score2))))))))))
|
||||
|
||||
|
||||
(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")))))
|
||||
|
|
|
|||
50
guix/ui.scm
50
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))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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))))
|
||||
|
||||
|
||||
(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\"."
|
||||
|
|
|
|||
Loading…
Reference in New Issue