;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix ui)
#:use-module (guix i18n)
#:use-module (guix colors)
+ #:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (guix utils)
#: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
#:use-module (texinfo)
#:use-module (texinfo plain-text)
#:use-module (texinfo string-utils)
- #:re-export (G_ N_ P_) ;backward compatibility
- #:export (report-error
- display-hint
- leave
+
+ ;; Re-exports for backward compatibility.
+ #:re-export (G_ N_ P_ ;now in (guix i18n)
+
+ warning info report-error leave ;now in (guix diagnostics)
+ location->string
+ guix-warning-port program-name)
+ #:export (display-hint
make-user-module
load*
warn-about-load-error
read/eval
read/eval-package-expression
check-available-space
- location->string
fill-paragraph
%text-width
texi->plain-text
string->recutils
package->recutils
package-specification->name+version+output
+
relevance
package-relevance
+ display-search-results
+
string->generations
string->duration
matching-generations
delete-generation*
run-guix-command
run-guix
- program-name
- guix-warning-port
- warning
- info
guix-main))
;;; Commentary:
;;;
;;; Code:
-(define-syntax highlight-argument
- (lambda (s)
- "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
-is a trivial format string."
- (define (trivial-format-string? fmt)
- (define len
- (string-length fmt))
-
- (let loop ((start 0))
- (or (>= (+ 1 start) len)
- (let ((tilde (string-index fmt #\~ start)))
- (or (not tilde)
- (case (string-ref fmt (+ tilde 1))
- ((#\a #\A #\%) (loop (+ tilde 2)))
- (else #f)))))))
-
- ;; Be conservative: limit format argument highlighting to cases where the
- ;; format string contains nothing but ~a escapes. If it contained ~s
- ;; escapes, this strategy wouldn't work.
- (syntax-case s ()
- ((_ "~a~%" arg) ;don't highlight whole messages
- #'arg)
- ((_ fmt arg)
- (trivial-format-string? (syntax->datum #'fmt))
- #'(%highlight-argument arg))
- ((_ fmt arg)
- #'arg))))
-
-(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
- "Highlight ARG, a format string argument, if PORT supports colors."
- (define highlight
- (if (color-output? port)
- (lambda (str)
- (apply colorize-string str %highlight-colors))
- identity))
-
- (cond ((string? arg)
- (highlight arg))
- ((symbol? arg)
- (highlight (symbol->string arg)))
- (else arg)))
-
-(define-syntax define-diagnostic
- (syntax-rules ()
- "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
-messages."
- ((_ name (G_ prefix) colors)
- (define-syntax name
- (lambda (x)
- (syntax-case x ()
- ((name location (underscore fmt) args (... ...))
- (and (string? (syntax->datum #'fmt))
- (free-identifier=? #'underscore #'G_))
- #'(begin
- (print-diagnostic-prefix prefix location
- #:colors colors)
- (format (guix-warning-port) (gettext fmt %gettext-domain)
- (highlight-argument fmt args) (... ...))))
- ((name location (N-underscore singular plural n)
- args (... ...))
- (and (string? (syntax->datum #'singular))
- (string? (syntax->datum #'plural))
- (free-identifier=? #'N-underscore #'N_))
- #'(begin
- (print-diagnostic-prefix prefix location
- #:colors colors)
- (format (guix-warning-port)
- (ngettext singular plural n %gettext-domain)
- (highlight-argument singular args) (... ...))))
- ((name (underscore fmt) args (... ...))
- (free-identifier=? #'underscore #'G_)
- #'(name #f (underscore fmt) args (... ...)))
- ((name (N-underscore singular plural n)
- args (... ...))
- (free-identifier=? #'N-underscore #'N_)
- #'(name #f (N-underscore singular plural n)
- args (... ...)))))))))
-
-;; XXX: This doesn't work well for right-to-left languages.
-;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
-;; "~a" is a placeholder for that phrase.
-(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning
-(define-diagnostic info (G_ "") %info-colors)
-(define-diagnostic report-error (G_ "error: ") %error-colors)
-
-(define-syntax-rule (leave args ...)
- "Emit an error message and exit."
- (begin
- (report-error args ...)
- (exit 1)))
-
-(define %warning-colors '(BOLD MAGENTA))
-(define %info-colors '(BOLD))
-(define %error-colors '(BOLD RED))
-(define %hint-colors '(BOLD CYAN))
-(define %highlight-colors '(BOLD))
-
-(define* (print-diagnostic-prefix prefix #:optional location
- #:key (colors '()))
- "Print PREFIX as a diagnostic line prefix."
- (define color?
- (color-output? (guix-warning-port)))
-
- (define location-color
- (if color?
- (cut colorize-string <> 'BOLD)
- identity))
-
- (define prefix-color
- (if color?
- (lambda (prefix)
- (apply colorize-string prefix colors))
- identity))
-
- (let ((prefix (if (string-null? prefix)
- prefix
- (gettext prefix %gettext-domain))))
- (if location
- (format (guix-warning-port) "~a: ~a"
- (location-color (location->string location))
- (prefix-color prefix))
- (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
- (program-name) (program-name)
- (prefix-color prefix)))))
-
(define (print-unbound-variable-error port key args default-printer)
;; Print unbound variable errors more nicely, and in the right language.
(match args
(('gnu _ ...) head) ;must be that one
(_ (loop next (cons head suggestions) visited)))))))))))
+(define %hint-color (color BOLD CYAN))
+
(define* (display-hint message #:optional (port (current-error-port)))
"Display MESSAGE, a l10n message possibly containing Texinfo markup, to
PORT."
(define colorize
(if (color-output? port)
(lambda (str)
- (apply colorize-string str %hint-colors))
+ (colorize-string str %hint-color))
identity))
(display (colorize (G_ "hint: ")) port)
(display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
(module-name module))))))))
+(define (check-module-matches-file module file)
+ "Check whether FILE starts with 'define-module MODULE' and print a hint if
+it doesn't."
+ ;; This is a common mistake when people start writing their own package
+ ;; definitions and try loading them with 'guix build -L …', so help them
+ ;; diagnose the problem.
+ (define (hint)
+ (display-hint (format #f (G_ "File @file{~a} should probably start with:
+
+@example\n(define-module ~a)\n@end example")
+ file module)))
+
+ (catch 'system-error
+ (lambda ()
+ (let* ((sexp (call-with-input-file file read))
+ (loc (and (pair? sexp)
+ (source-properties->location (source-properties sexp)))))
+ (match sexp
+ (('define-module (names ...) _ ...)
+ (unless (equal? module names)
+ (warning loc
+ (G_ "module name ~a does not match file name '~a'~%")
+ names (module->source-file-name module))
+ (hint)))
+ ((? eof-object?)
+ (warning (G_ "~a: file is empty~%") file))
+ (else
+ (hint)))))
+ (const #f)))
+
(define* (report-load-error file args #:optional frame)
"Report the failure to load FILE, a user-provided Scheme file.
ARGS is the list of arguments received by the 'throw' handler."
;; above and need to be printed with 'print-exception'.
(print-exception (current-error-port) frame key args))))))
-(define (warn-about-load-error file args) ;FIXME: factorize with ↑
+(define (warn-about-load-error file module args) ;FIXME: factorize with ↑
"Report the failure to load FILE, a user-provided Scheme file, without
exiting. ARGS is the list of arguments received by the 'throw' handler."
(match args
(('system-error . rest)
(let ((err (system-error-errno args)))
- (warning (G_ "failed to load '~a': ~a~%") file (strerror err))))
+ (warning (G_ "failed to load '~a': ~a~%") module (strerror err))))
(('syntax-error proc message properties form . rest)
(let ((loc (source-properties->location properties)))
(warning loc (G_ "~a~%") message)))
+ (('unbound-variable _ ...)
+ (report-unbound-variable-error args))
(('srfi-34 obj)
(if (message-condition? obj)
(warning (G_ "failed to load '~a': ~a~%")
(warning (G_ "failed to load '~a': exception thrown: ~s~%")
file obj)))
((error args ...)
- (warning (G_ "failed to load '~a':~%") file)
- (apply display-error #f (current-error-port) args))))
+ (warning (G_ "failed to load '~a':~%") module)
+ (apply display-error #f (current-error-port) args)
+ (check-module-matches-file module file))))
(define (call-with-unbound-variable-handling thunk)
(define tag
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)))
#: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 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))))
- ((download) ; add the references of DOWNLOAD
- (if use-substitutes?
- (delete-duplicates
- (append download
- (filter-map (lambda (item)
- (if (valid-path? store item)
- #f
- (substitutable-info item)))
- (append-map
- substitutable-references
- download))))
- download))
+ (derivation-build-plan store inputs
+ #:mode mode
+ #:substitutable-info
+ substitutable-info))
((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
(lambda ()
body ...)))))
-(define (location->string loc)
- "Return a human-friendly, GNU-standard representation of LOC."
- (match loc
- (#f (G_ "<unknown location>"))
- (($ <location> file line column)
- (format #f "~a:~a:~a" file line column))))
-
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
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
-field/weight pairs, where FIELD is a procedure that returns a string
-describing OBJ, and WEIGHT is a positive integer denoting the weight of this
-field in the final score.
+field/weight pairs, where FIELD is a procedure that returns a string or list
+of strings describing OBJ, and WEIGHT is a positive integer denoting the
+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
((field . weight)
(match (field obj)
(#f relevance)
- (str (+ relevance
- (* (score str) weight)))))))
+ ((? string? str)
+ (+ relevance (* (score str) weight)))
+ ((lst ...)
+ (+ relevance (* weight (apply + (map score lst)))))))))
0
metrics))
;; of regexps.
`((,package-name . 4)
+ ;; Match against uncommon outputs.
+ (,(lambda (package)
+ (filter (lambda (output)
+ (not (member output
+ ;; Some common outpus shared by many packages.
+ '("out" "doc" "debug" "lib" "include" "bin"))))
+ (package-outputs package)))
+ . 1)
+
;; Match regexps on the raw Texinfo since formatting it is quite expensive
;; and doesn't have much of an effect on search results.
(,(lambda (package)
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\"."
((string->duration str)
=>
filter-by-duration)
- (else #f)))
+ (else
+ (raise
+ (condition (&message
+ (message (format #f (G_ "invalid syntax: ~a~%")
+ str))))))))
(define (display-generation profile number)
"Display a one-line summary of generation NUMBER of PROFILE."
(unless (zero? number)
- (let ((header (format #f (G_ "Generation ~a\t~a") number
+ (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number
(date->string
(time-utc->date
(generation-time profile number))
string<?))
(show-bug-report-information))
-(define program-name
- ;; Name of the command-line program currently executing, or #f.
- (make-parameter #f))
-
(define (run-guix-command command . args)
"Run COMMAND with the given ARGS. Report an error when COMMAND is not
found."
(string->symbol command)
args))))
-(define guix-warning-port
- (make-parameter (current-warning-port)))
-
(define (guix-main arg0 . args)
(initialize-guix)
(apply run-guix args))
HCoop / jackhill / guix / guix.git / blobdiff