diff options
Diffstat (limited to 'guix/ui.scm')
| -rw-r--r-- | guix/ui.scm | 142 |
1 files changed, 95 insertions, 47 deletions
diff --git a/guix/ui.scm b/guix/ui.scm index 0b4fe144b6..6d243ef041 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -41,12 +41,12 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) - #:use-module (guix combinators) #:use-module (guix build-system) #: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 +106,11 @@ string->recutils package->recutils package-specification->name+version+output + relevance package-relevance + display-search-results + string->generations string->duration matching-generations @@ -774,12 +777,19 @@ error." str)))) (define (show-derivation-outputs derivation) - "Show the output file names of DERIVATION." - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path derivation out-name))) - (derivation-outputs derivation)))) + "Show the output file names of DERIVATION, which can be a derivation or a +derivation input." + (define (show-outputs derivation outputs) + (format #t "~{~a~%~}" + (map (cut derivation->output-path derivation <>) + outputs))) + + (match derivation + ((? derivation?) + (show-outputs derivation (derivation-output-names derivation))) + ((? derivation-input? input) + (show-outputs (derivation-input-derivation input) + (derivation-input-sub-derivations input))))) (define* (check-available-space need #:optional (directory (%store-prefix))) @@ -809,40 +819,31 @@ warning." #:key dry-run? (use-substitutes? #t) (mode (build-mode normal))) "Show what will or would (depending on DRY-RUN?) be built in realizing the -derivations listed in DRV using MODE, a 'build-mode' value. Return #t if -there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and -report what is prerequisites are available for download." +derivations listed in DRV using MODE, a 'build-mode' value. The elements of +DRV can be either derivations or derivation inputs. + +Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, +check and report what is prerequisites are available for download." + (define inputs + (map (match-lambda + ((? derivation? drv) (derivation-input drv)) + ((? derivation-input? input) input)) + drv)) + (define substitutable-info ;; Call 'substitutation-oracle' upfront so we don't end up launching the ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. (if use-substitutes? - (substitution-oracle store drv #:mode mode) + (substitution-oracle store (map derivation-input-derivation inputs) + #:mode mode) (const #f))) - (define (built-or-substitutable? drv) - (or (null? (derivation-outputs drv)) - (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists - (or (valid-path? store out) - (substitutable-info out))))) - (let*-values (((build download) - (fold2 (lambda (drv build download) - (let-values (((b d) - (derivation-prerequisites-to-build - store drv - #:mode mode - #:substitutable-info - substitutable-info))) - (values (append b build) - (append d download)))) - '() '() - drv)) - ((build) ; add the DRV themselves - (delete-duplicates - (append (map derivation-file-name - (remove built-or-substitutable? drv)) - (map derivation-input-path build)))) + (derivation-build-plan store inputs + #:mode mode + #:substitutable-info + substitutable-info)) ((download) ; add the references of DOWNLOAD (if use-substitutes? (delete-duplicates @@ -856,8 +857,8 @@ report what is prerequisites are available for download." download)))) download)) ((graft hook build) - (match (fold (lambda (file acc) - (let ((drv (read-derivation-from-file file))) + (match (fold (lambda (drv acc) + (let ((file (derivation-file-name drv))) (match acc ((#:graft graft #:hook hook #:build build) (cond @@ -1246,6 +1247,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 @@ -1256,17 +1262,20 @@ 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) - (let ((counts (map (lambda (regexp) - (match (fold-matches regexp str '() cons) - (() 0) - ((m) (if (string=? (match:substring m) str) - 5 ;exact match - 1)) - (lst (length lst)))) - regexps))) - ;; Compute a score that's proportional to the number of regexps matched - ;; and to the number of matches for each regexp. - (* (length counts) (reduce + 0 counts)))) + (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)) + + ;; Return zero if one of REGEXPS doesn't match. + (if (any zero? scores) + 0 + (reduce + 0 scores))) (fold (lambda (metric relevance) (match metric @@ -1312,6 +1321,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\"." |