diff options
author | Ludovic Courtès <ludo@gnu.org> | 2019-06-27 23:33:48 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2019-06-27 23:33:48 +0200 |
commit | 5cc1075a76392666d3d733837f5c6252b1e48002 (patch) | |
tree | aff2a303881a6fe53021a6e78a767958e608719b /guix | |
parent | 9c2563a80b6f1d8fb8677f5314e6180ea9916aa5 (diff) | |
parent | c30d117822a8ca26cd8c06c0a3974955bef68eac (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/compile.scm | 3 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 37 | ||||
-rw-r--r-- | guix/derivations.scm | 277 | ||||
-rw-r--r-- | guix/progress.scm | 4 | ||||
-rw-r--r-- | guix/scripts/build.scm | 11 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 3 | ||||
-rw-r--r-- | guix/scripts/package.scm | 41 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 26 | ||||
-rw-r--r-- | guix/scripts/system/search.scm | 44 | ||||
-rw-r--r-- | guix/ui.scm | 142 |
10 files changed, 348 insertions, 240 deletions
diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 794f12379c..c8fe273f7e 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -63,7 +63,8 @@ ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need ;; help from Guile to solve this. '(unsupported-warning unbound-variable arity-mismatch - macro-use-before-definition)) ;new in 2.2 + macro-use-before-definition ;new in 2.2 + shadowed-toplevel)) ;new in 2.2.5 (define (optimization-options file) "Return the default set of optimizations options for FILE." diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 5c2eb3c14d..eb045cbd1c 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -146,6 +146,7 @@ window-size-y-pixels terminal-window-size terminal-columns + terminal-rows utmpx? utmpx-login-type @@ -1871,23 +1872,17 @@ corresponds to the TIOCGWINSZ ioctl." (list (strerror err)) (list err))))) -(define* (terminal-columns #:optional (port (current-output-port))) - "Return the best approximation of the number of columns of the terminal at -PORT, trying to guess a reasonable value if all else fails. The result is -always a positive integer." - (define (fall-back) - (match (and=> (getenv "COLUMNS") string->number) - (#f 80) - ((? number? columns) - (if (> columns 0) columns 80)))) - +(define (terminal-dimension window-dimension port fall-back) + "Return the terminal dimension defined by WINDOW-DIMENSION, one of +'window-size-columns' or 'window-size-rows' for PORT. If PORT does not +correspond to a terminal, return the value returned by FALL-BACK." (catch 'system-error (lambda () (if (file-port? port) - (match (window-size-columns (terminal-window-size port)) + (match (window-dimension (terminal-window-size port)) ;; Things like Emacs shell-mode return 0, which is unreasonable. (0 (fall-back)) - ((? number? columns) columns)) + ((? number? n) n)) (fall-back))) (lambda args (let ((errno (system-error-errno args))) @@ -1900,6 +1895,24 @@ always a positive integer." (fall-back) (apply throw args)))))) +(define* (terminal-columns #:optional (port (current-output-port))) + "Return the best approximation of the number of columns of the terminal at +PORT, trying to guess a reasonable value if all else fails. The result is +always a positive integer." + (define (fall-back) + (match (and=> (getenv "COLUMNS") string->number) + (#f 80) + ((? number? columns) + (if (> columns 0) columns 80)))) + + (terminal-dimension window-size-columns port fall-back)) + +(define* (terminal-rows #:optional (port (current-output-port))) + "Return the best approximation of the number of rows of the terminal at +PORT, trying to guess a reasonable value if all else fails. The result is +always a positive integer." + (terminal-dimension window-size-rows port (const 25))) + ;;; ;;; utmpx. diff --git a/guix/derivations.scm b/guix/derivations.scm index 8145d51143..433b4551a5 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -21,6 +21,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -34,6 +35,7 @@ #:use-module (guix base16) #:use-module (guix memoization) #:use-module (guix combinators) + #:use-module (guix deprecation) #:use-module (guix monads) #:use-module (gcrypt hash) #:use-module (guix base32) @@ -50,7 +52,8 @@ derivation-builder-environment-vars derivation-file-name derivation-prerequisites - derivation-prerequisites-to-build + derivation-build-plan + derivation-prerequisites-to-build ;deprecated <derivation-output> derivation-output? @@ -61,6 +64,7 @@ <derivation-input> derivation-input? + derivation-input derivation-input-path derivation-input-derivation derivation-input-sub-derivations @@ -148,14 +152,28 @@ (recursive? derivation-output-recursive?)) ; Boolean (define-immutable-record-type <derivation-input> - (make-derivation-input path sub-derivations) + (make-derivation-input drv sub-derivations) derivation-input? - (path derivation-input-path) ; store path + (drv derivation-input-derivation) ; <derivation> (sub-derivations derivation-input-sub-derivations)) ; list of strings -(define (derivation-input-derivation input) - "Return the <derivation> object INPUT refers to." - (read-derivation-from-file (derivation-input-path input))) + +(define (derivation-input-path input) + "Return the file name of the derivation INPUT refers to." + (derivation-file-name (derivation-input-derivation input))) + +(define* (derivation-input drv #:optional + (outputs (derivation-output-names drv))) + "Return a <derivation-input> for the OUTPUTS of DRV." + ;; This is a public interface meant to be more convenient than + ;; 'make-derivation-input' and giving us more control. + (make-derivation-input drv outputs)) + +(define (derivation-input-key input) + "Return an object for which 'equal?' and 'hash' are constant-time, and which +can thus be used as a key for INPUT in lookup tables." + (cons (derivation-input-path input) + (derivation-input-sub-derivations input))) (set-record-type-printer! <derivation> (lambda (drv port) @@ -197,8 +215,8 @@ download with a fixed hash (aka. `fetchurl')." "Return the list of output paths corresponding to INPUT, a <derivation-input>." (match input - (($ <derivation-input> path sub-drvs) - (map (cut derivation-path->output-path path <>) + (($ <derivation-input> drv sub-drvs) + (map (cut derivation->output-path drv <>) sub-drvs)))) (define (valid-derivation-input? store input) @@ -213,20 +231,20 @@ they are coalesced, with their sub-derivations merged. This is needed because Nix itself keeps only one of them." (fold (lambda (input result) (match input - (($ <derivation-input> path sub-drvs) + (($ <derivation-input> (= derivation-file-name path) sub-drvs) ;; XXX: quadratic (match (find (match-lambda - (($ <derivation-input> p s) + (($ <derivation-input> (= derivation-file-name p) + s) (string=? p path))) result) (#f (cons input result)) - ((and dup ($ <derivation-input> _ sub-drvs2)) + ((and dup ($ <derivation-input> drv sub-drvs2)) ;; Merge DUP with INPUT. (let ((sub-drvs (delete-duplicates (append sub-drvs sub-drvs2)))) - (cons (make-derivation-input path - (sort sub-drvs string<?)) + (cons (make-derivation-input drv (sort sub-drvs string<?)) (delq dup result)))))))) '() inputs)) @@ -242,12 +260,14 @@ result is the set of prerequisites of DRV not already in valid." (result '()) (input-set (set))) (let ((inputs (remove (lambda (input) - (or (set-contains? input-set input) + (or (set-contains? input-set + (derivation-input-key input)) (cut? input))) (derivation-inputs drv)))) (fold2 loop (append inputs result) - (fold set-insert input-set inputs) + (fold set-insert input-set + (map derivation-input-key inputs)) (map derivation-input-derivation inputs))))) (define (offloadable-derivation? drv) @@ -333,87 +353,81 @@ substituter many times." (#f #f) ((key . value) value))))) -(define* (derivation-prerequisites-to-build store drv - #:key - (mode (build-mode normal)) - (outputs - (derivation-output-names drv)) - (substitutable-info - (substitution-oracle store - (list drv) - #:mode mode))) - "Return two values: the list of derivation-inputs required to build the -OUTPUTS of DRV and not already available in STORE, recursively, and the list -of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a -one-argument procedure similar to that returned by 'substitution-oracle'." - (define built? - (mlambda (item) - (valid-path? store item))) - - (define input-built? - (compose (cut any built? <>) derivation-input-output-paths)) - - (define input-substitutable? - ;; Return true if and only if all of SUB-DRVS are subsitutable. If at - ;; least one is missing, then everything must be rebuilt. - (compose (cut every substitutable-info <>) derivation-input-output-paths)) - - (define (derivation-built? drv* sub-drvs) +(define* (derivation-build-plan store inputs + #:key + (mode (build-mode normal)) + (substitutable-info + (substitution-oracle + store + (map derivation-input-derivation + inputs) + #:mode mode))) + "Given INPUTS, a list of derivation-inputs, return two values: the list of +derivation to build, and the list of substitutable items that, together, +allows INPUTS to be realized. + +SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned +by 'substitution-oracle'." + (define (built? item) + (valid-path? store item)) + + (define (input-built? input) ;; In 'check' mode, assume that DRV is not built. (and (not (and (eqv? mode (build-mode check)) - (eq? drv* drv))) - (every built? (derivation-output-paths drv* sub-drvs)))) - - (define (derivation-substitutable-info drv sub-drvs) - (and (substitutable-derivation? drv) - (let ((info (filter-map substitutable-info - (derivation-output-paths drv sub-drvs)))) - (and (= (length info) (length sub-drvs)) + (member input inputs))) + (every built? (derivation-input-output-paths input)))) + + (define (input-substitutable-info input) + (and (substitutable-derivation? (derivation-input-derivation input)) + (let* ((items (derivation-input-output-paths input)) + (info (filter-map substitutable-info items))) + (and (= (length info) (length items)) info)))) - (let loop ((drv drv) - (sub-drvs outputs) - (build '()) ;list of <derivation-input> - (substitute '())) ;list of <substitutable> - (cond ((derivation-built? drv sub-drvs) - (values build substitute)) - ((derivation-substitutable-info drv sub-drvs) - => - (lambda (substitutables) - (values build - (append substitutables substitute)))) - (else - (let ((build (if (substitutable-derivation? drv) - build - (cons (make-derivation-input - (derivation-file-name drv) sub-drvs) - build))) - (inputs (remove (lambda (i) - (or (member i build) ; XXX: quadratic - (input-built? i) - (input-substitutable? i))) - (derivation-inputs drv)))) - (fold2 loop - (append inputs build) - (append (append-map (lambda (input) - (if (and (not (input-built? input)) - (input-substitutable? input)) - (map substitutable-info - (derivation-input-output-paths - input)) - '())) - (derivation-inputs drv)) - substitute) - (map (lambda (i) - (read-derivation-from-file - (derivation-input-path i))) - inputs) - (map derivation-input-sub-derivations inputs))))))) - -(define (read-derivation drv-port) + (let loop ((inputs inputs) ;list of <derivation-input> + (build '()) ;list of <derivation> + (substitute '()) ;list of <substitutable> + (visited (set))) ;set of <derivation-input> + (match inputs + (() + (values build substitute)) + ((input rest ...) + (let ((key (derivation-input-key input))) + (cond ((set-contains? visited key) + (loop rest build substitute visited)) + ((input-built? input) + (loop rest build substitute + (set-insert key visited))) + ((input-substitutable-info input) + => + (lambda (substitutables) + (loop rest build + (append substitutables substitute) + (set-insert key visited)))) + (else + (let ((deps (derivation-inputs + (derivation-input-derivation input)))) + (loop (append deps rest) + (cons (derivation-input-derivation input) build) + substitute + (set-insert key visited)))))))))) + +(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) + derivation-build-plan + (let-values (((build download) + (apply derivation-build-plan store + (list (derivation-input drv)) rest))) + (values (map derivation-input build) download))) + +(define* (read-derivation drv-port + #:optional (read-derivation-from-file + read-derivation-from-file)) "Read the derivation from DRV-PORT and return the corresponding <derivation> -object. Most of the time you'll want to use 'read-derivation-from-file', -which caches things as appropriate and is thus more efficient." +object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs +of the derivation being parsed. + +Most of the time you'll want to use 'read-derivation-from-file', which caches +things as appropriate and is thus more efficient." (define comma (string->symbol ",")) @@ -449,8 +463,9 @@ which caches things as appropriate and is thus more efficient." (fold-right (lambda (input result) (match input ((path (sub-drvs ...)) - (cons (make-derivation-input path sub-drvs) - result)))) + (let ((drv (read-derivation-from-file path))) + (cons (make-derivation-input drv sub-drvs) + result))))) '() x)) @@ -552,9 +567,15 @@ that form." (define (write-input input port) (match input - (($ <derivation-input> path sub-drvs) + (($ <derivation-input> obj sub-drvs) (display "(\"" port) - (display path port) + + ;; 'derivation/masked-inputs' produces objects that contain a string + ;; instead of a <derivation>, so we need to account for that. + (display (if (derivation? obj) + (derivation-file-name obj) + obj) + port) (display "\"," port) (write-string-list sub-drvs) (display ")" port)))) @@ -645,13 +666,16 @@ name of each input with that input's hash." (($ <derivation> outputs inputs sources system builder args env-vars) (let ((inputs (map (match-lambda - (($ <derivation-input> path sub-drvs) + (($ <derivation-input> (= derivation-file-name path) + sub-drvs) (let ((hash (derivation-path->base16-hash path))) (make-derivation-input hash sub-drvs)))) inputs))) (make-derivation outputs - (sort (coalesce-duplicate-inputs inputs) - derivation-input<?) + (sort inputs + (lambda (drv1 drv2) + (string<? (derivation-input-derivation drv1) + (derivation-input-derivation drv2)))) sources system builder args env-vars #f))))) @@ -807,17 +831,19 @@ derivation. It is kept as-is, uninterpreted, in the derivation." (define input->derivation-input (match-lambda (((? derivation? drv)) - (make-derivation-input (derivation-file-name drv) '("out"))) + (make-derivation-input drv '("out"))) (((? derivation? drv) sub-drvs ...) - (make-derivation-input (derivation-file-name drv) sub-drvs)) - (((? direct-store-path? input)) - (make-derivation-input input '("out"))) - (((? direct-store-path? input) sub-drvs ...) - (make-derivation-input input sub-drvs)) - ((input . _) - (let ((path (add-to-store store (basename input) - #t "sha256" input))) - (make-derivation-input path '()))))) + (make-derivation-input drv sub-drvs)) + (_ #f))) + + (define input->source + (match-lambda + (((? string? input) . _) + (if (direct-store-path? input) + input + (add-to-store store (basename input) + #t "sha256" input))) + (_ #f))) ;; Note: lists are sorted alphabetically, to conform with the behavior of ;; C++ `std::map' in Nix itself. @@ -828,32 +854,31 @@ derivation. It is kept as-is, uninterpreted, in the derivation." (make-derivation-output "" hash-algo hash recursive?))) (sort outputs string<?))) + (sources (sort (delete-duplicates + (filter-map input->source inputs)) + string<?)) (inputs (sort (coalesce-duplicate-inputs - (map input->derivation-input - (delete-duplicates inputs))) + (filter-map input->derivation-input inputs)) derivation-input<?)) (env-vars (sort (env-vars-with-empty-outputs (user+system-env-vars)) (lambda (e1 e2) (string<? (car e1) (car e2))))) - (drv-masked (make-derivation outputs - (filter (compose derivation-path? - derivation-input-path) - inputs) - (filter-map (lambda (i) - (let ((p (derivation-input-path i))) - (and (not (derivation-path? p)) - p))) - inputs) + (drv-masked (make-derivation outputs inputs sources system builder args env-vars #f)) (drv (add-output-paths drv-masked))) (let* ((file (add-data-to-store store (string-append name ".drv") (derivation->bytevector drv) - (map derivation-input-path inputs))) + (append (map derivation-input-path inputs) + sources))) (drv* (set-field drv (derivation-file-name) file))) - (hash-set! %derivation-cache file drv*) - drv*))) + ;; Preserve pointer equality. This improves the performance of + ;; 'eq?'-memoization on derivations. + (or (hash-ref %derivation-cache file) + (begin + (hash-set! %derivation-cache file drv*) + drv*))))) (define (invalidate-derivation-caches!) "Invalidate internal derivation caches. This is mostly useful for @@ -920,7 +945,8 @@ recursively." ;; in the format used in 'derivation' calls. (mlambda (input loop) (match input - (($ <derivation-input> path (sub-drvs ...)) + (($ <derivation-input> (= derivation-file-name path) + (sub-drvs ...)) (match (vhash-assoc path mapping) ((_ . (? derivation? replacement)) (cons replacement sub-drvs)) @@ -990,6 +1016,11 @@ derivation/output pairs, using the specified MODE." (build-things store (map (match-lambda ((? derivation? drv) (derivation-file-name drv)) + ((? derivation-input? input) + (cons (derivation-input-path input) + (string-join + (derivation-input-sub-derivations input) + ","))) ((? string? file) file) (((? derivation? drv) . output) (cons (derivation-file-name drv) diff --git a/guix/progress.scm b/guix/progress.scm index f150b081d6..349637dbcf 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -197,7 +197,9 @@ object) and TRANSFERRED (a total number of bytes) to determine the throughput." (define elapsed (duration->seconds - (time-difference (current-time time-monotonic) start-time))) + (time-difference (current-time (time-type start-time)) + start-time))) + (if (and (number? size) (not (zero? size))) (let* ((% (* 100.0 (/ transferred size))) (throughput (/ transferred elapsed)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 61ca4dca9f..ec58ba871b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -836,11 +836,9 @@ build." (#t (match (package-source p) (#f - (format (current-error-port) - (G_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) + (warning (package-location p) + (G_ "package '~a' has no source~%") + (package-name p)) '()) (s (list (package-source-derivation store s))))) @@ -918,7 +916,8 @@ needed." '()))) (items (filter-map (match-lambda (('argument . (? store-path? file)) - file) + (and (not (derivation-path? file)) + file)) (_ #f)) opts)) (roots (filter-map (match-lambda diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 8fe81ad64b..2e14857f1e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -254,8 +254,7 @@ GNU-BUILD-SYSTEM have zero dependencies." "Return the <derivation> objects and store items corresponding to the dependencies of OBJ, a <derivation> or store item." (if (derivation? obj) - (append (map (compose read-derivation-from-file derivation-input-path) - (derivation-inputs obj)) + (append (map derivation-input-derivation (derivation-inputs obj)) (derivation-sources obj)) '())) 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/publish.scm b/guix/scripts/publish.scm index b4334b3f16..c716998a5b 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -724,6 +724,32 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define %http-write (@@ (web server http) http-write)) +(match (list (major-version) (minor-version) (micro-version)) + (("2" "2" "5") ;Guile 2.2.5 + (let () + (define %read-line (@ (ice-9 rdelim) %read-line)) + (define bad-header (@@ (web http) bad-header)) + + ;; XXX: Work around <https://bugs.gnu.org/36350> by reverting to the + ;; definition of 'read-header-line' as found in 2.2.4 and earlier. + (define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + (bad-header 'read-header-line line)))) + + (set! (@@ (web http) read-header-line) read-header-line))) + (_ #t)) + (define (strip-headers response) "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete 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)))))))))) (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 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\"." |