;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
-;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
-;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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
roll-back*
switch-to-generation*
delete-generation*
+
+ %default-message-language
+ current-message-language
+
run-guix-command
run-guix
- program-name
- guix-warning-port
- warning
- info
- guix-main
- colorize-string))
+ guix-main))
;;; Commentary:
;;;
;;;
;;; Code:
-(define-syntax-rule (define-diagnostic name prefix)
- "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
-messages."
- (define-syntax name
- (lambda (x)
- (define (augmented-format-string fmt)
- (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
-
- (syntax-case x ()
- ((name (underscore fmt) args (... ...))
- (and (string? (syntax->datum #'fmt))
- (free-identifier=? #'underscore #'G_))
- (with-syntax ((fmt* (augmented-format-string #'fmt))
- (prefix (datum->syntax x prefix)))
- #'(format (guix-warning-port) (gettext fmt*)
- (program-name) (program-name) prefix
- args (... ...))))
- ((name (N-underscore singular plural n) args (... ...))
- (and (string? (syntax->datum #'singular))
- (string? (syntax->datum #'plural))
- (free-identifier=? #'N-underscore #'N_))
- (with-syntax ((s (augmented-format-string #'singular))
- (p (augmented-format-string #'plural))
- (prefix (datum->syntax x prefix)))
- #'(format (guix-warning-port)
- (ngettext s p n %gettext-domain)
- (program-name) (program-name) prefix
- args (... ...))))))))
-
-(define-diagnostic warning "warning: ") ; emit a warning
-(define-diagnostic info "")
-
-(define-diagnostic report-error "error: ")
-(define-syntax-rule (leave args ...)
- "Emit an error message and exit."
- (begin
- (report-error args ...)
- (exit 1)))
-
(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."
- (format port (G_ "hint: ~a~%")
- ;; XXX: We should arrange so that the initial indent is wider.
- (parameterize ((%text-width (max 15
- (- (terminal-columns) 5))))
- (texi->plain-text message))))
+ (define colorize
+ (if (color-output? port)
+ (lambda (str)
+ (colorize-string str %hint-color))
+ identity))
+
+ (display (colorize (G_ "hint: ")) port)
+ (display
+ ;; XXX: We should arrange so that the initial indent is wider.
+ (parameterize ((%text-width (max 15 (- (terminal-columns) 5))))
+ (texi->plain-text message))
+ port))
(define* (report-unbound-variable-error args #:key frame)
"Return the given unbound-variable error, where ARGS is the list of 'throw'
(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."
(apply throw args)))
(('syntax-error proc message properties form . rest)
(let ((loc (source-properties->location properties)))
- (format (current-error-port) (G_ "~a: error: ~a~%")
- (location->string loc) message)))
+ (report-error loc (G_ "~a~%") message)))
(('unbound-variable _ ...)
(report-unbound-variable-error args #:frame frame))
(('srfi-34 obj)
(if (message-condition? obj)
- (if (error-location? obj)
- (format (current-error-port)
- (G_ "~a: error: ~a~%")
- (location->string (error-location obj))
- (gettext (condition-message obj)
- %gettext-domain))
- (report-error (G_ "~a~%")
- (gettext (condition-message obj)
- %gettext-domain)))
+ (report-error (and (error-location? obj)
+ (error-location obj))
+ (G_ "~a~%")
+ (gettext (condition-message obj) %gettext-domain))
(report-error (G_ "exception thrown: ~s~%") obj))
(when (fix-hint? obj)
(display-hint (condition-fix-hint obj))))
- ((error args ...)
+ ((key args ...)
(report-error (G_ "failed to load '~a':~%") file)
- (apply display-error frame (current-error-port) args))))
-
-(define (warn-about-load-error file args) ;FIXME: factorize with ↑
+ (match args
+ (((? symbol? proc) (? string? message) (args ...) . rest)
+ (display-error frame (current-error-port) proc message
+ args rest))
+ (_
+ ;; Some exceptions like 'git-error' do not follow Guile's convention
+ ;; above and need to be printed with 'print-exception'.
+ (print-exception (current-error-port) frame key args))))))
+
+(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)))
- (format (current-error-port) (G_ "~a: warning: ~a~%")
- (location->string loc) message)))
+ (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
report them in a user-friendly way."
(call-with-unbound-variable-handling (lambda () exp ...)))
+(define %default-message-language
+ ;; Default language to use for messages.
+ (make-parameter "en"))
+
+(define (current-message-language)
+ "Return the language used for messages according to the current locale.
+Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The
+result is an ISO-639-2 language code such as \"ar\", without the territory
+part."
+ (let ((locale (setlocale LC_MESSAGES)))
+ (match (string-index locale #\_)
+ (#f locale)
+ (index (string-take locale index)))))
+
(define (install-locale)
"Install the current locale settings."
(catch 'system-error
(lambda _
(setlocale LC_ALL ""))
(lambda args
- (cond-expand
- ;; Guile 2.2 already emits a warning, so let's not add a second one.
- (guile-2.2 #t)
- (else (warning (G_ "failed to install locale: ~a~%")
- (strerror (system-error-errno args)))))
(display-hint (G_ "Consider installing the @code{glibc-utf8-locales} or
@code{glibc-locales} package and defining @code{GUIX_LOCPATH}, along these
lines:
;; notified via an EPIPE later.
(sigaction SIGPIPE SIG_IGN)
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF))
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line))
(define* (show-version-and-exit #:optional (command (car (command-line))))
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
- (format #t "Copyright ~a 2018 ~a"
+ (format #t "Copyright ~a 2019 ~a"
;; TRANSLATORS: Translate "(C)" to the copyright symbol
;; (C-in-a-circle), if this symbol is available in the user's
;; locale. Otherwise, do not translate "(C)"; leave it as-is. */
(leave (G_ "generation ~a of profile '~a' does not exist~%")
(missing-generation-error-generation c)
(profile-error-profile c)))
+ ((unmatched-pattern-error? c)
+ (let ((pattern (unmatched-pattern-error-pattern c)))
+ (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
+ (manifest-pattern-name pattern)
+ (manifest-pattern-version pattern)
+ (match (manifest-pattern-output pattern)
+ ("out" #f)
+ (output output)))))
((profile-collision-error? c)
(let ((entry (profile-collision-error-entry c))
(conflict (profile-collision-error-conflict c)))
file (or (port-filename* port) port))
(leave (G_ "corrupt input while restoring archive from ~s~%")
(or (port-filename* port) port)))))
- ((nix-connection-error? c)
+ ((store-connection-error? c)
(leave (G_ "failed to connect to `~a': ~a~%")
- (nix-connection-error-file c)
- (strerror (nix-connection-error-code c))))
- ((nix-protocol-error? c)
+ (store-connection-error-file c)
+ (strerror (store-connection-error-code c))))
+ ((store-protocol-error? c)
;; FIXME: Server-provided error messages aren't i18n'd.
- (leave (G_ "build failed: ~a~%")
- (nix-protocol-error-message c)))
+ (leave (G_ "~a~%")
+ (store-protocol-error-message c)))
((derivation-missing-output-error? c)
(leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
(derivation-missing-output c)
(cons (invoke-error-program c)
(invoke-error-arguments c))))
((and (error-location? c) (message-condition? c))
- (format (current-error-port)
- (G_ "~a: error: ~a~%")
- (location->string (error-location c))
- (gettext (condition-message c) %gettext-domain))
+ (report-error (error-location c) (G_ "~a~%")
+ (gettext (condition-message c) %gettext-domain))
(when (fix-hint? c)
(display-hint (condition-fix-hint c)))
(exit 1))
((and (message-condition? c) (fix-hint? c))
- (format (current-error-port) "~a: error: ~a~%"
- (program-name)
- (gettext (condition-message c) %gettext-domain))
+ (report-error (G_ "~a~%")
+ (gettext (condition-message c) %gettext-domain))
(display-hint (condition-fix-hint c))
(exit 1))
((message-condition? c)
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)))
('graft #t)
(_ #f)))
+(define (profile-hook-derivation? drv)
+ "Return true if DRV is definitely a profile hook derivation, false otherwise."
+ (match (assq-ref (derivation-properties drv) 'type)
+ ('profile-hook #t)
+ (_ #f)))
+
(define* (show-what-to-build store drv
#: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))
- ((graft build)
- (partition (compose graft-derivation?
- read-derivation-from-file)
- build)))
+ (derivation-build-plan store inputs
+ #:mode mode
+ #:substitutable-info
+ substitutable-info))
+ ((graft hook build)
+ (match (fold (lambda (drv acc)
+ (let ((file (derivation-file-name drv)))
+ (match acc
+ ((#:graft graft #:hook hook #:build build)
+ (cond
+ ((graft-derivation? drv)
+ `(#:graft ,(cons file graft)
+ #:hook ,hook
+ #:build ,build))
+ ((profile-hook-derivation? drv)
+ `(#:graft ,graft
+ #:hook ,(cons file hook)
+ #:build ,build))
+ (else
+ `(#:graft ,graft
+ #:hook ,hook
+ #:build ,(cons file build))))))))
+ '(#:graft () #:hook () #:build ())
+ build)
+ ((#:graft graft #:hook hook #:build build)
+ (values graft hook build)))))
(define installed-size
(reduce + 0 (map substitutable-nar-size download)))
(N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft))
+ (null? graft) graft)
+ (format (current-error-port)
+ (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
+ "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
+ (length hook))
+ (null? hook) hook))
(begin
(format (current-error-port)
(N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
(N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft)))
+ (null? graft) graft)
+ (format (current-error-port)
+ (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
+ "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
+ (length hook))
+ (null? hook) hook)))
(check-available-space installed-size)
(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))))
-
- (fold (lambda (metric relevance)
- (match metric
- ((field . weight)
- (match (field obj)
- (#f relevance)
- (str (+ relevance
- (* (score str) weight)))))))
+ (define (score regexp str)
+ (fold-matches regexp str 0
+ (lambda (m score)
+ (+ score
+ (if (string=? (match:substring m) str)
+ 5 ;exact match
+ 1)))))
+
+ (define (regexp->score regexp)
+ (let ((score-regexp (lambda (str) (score regexp str))))
+ (fold (lambda (metric relevance)
+ (match metric
+ ((field . weight)
+ (match (field obj)
+ (#f relevance)
+ ((? string? str)
+ (+ relevance (* (score-regexp str) weight)))
+ ((lst ...)
+ (+ relevance (* weight (apply + (map score-regexp lst)))))))))
+ 0 metrics)))
+
+ (let ((scores (map regexp->score regexps)))
+ ;; Return zero if one of REGEXPS doesn't match.
+ (if (any zero? scores)
0
- metrics))
+ (reduce + 0 scores))))
(define %package-metrics
;; Metrics used to compute the "relevance score" of a package against a set
;; of regexps.
`((,package-name . 4)
- (,package-synopsis-string . 3)
- (,package-description-string . 2)
+
+ ;; 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)
+ (and=> (package-synopsis package) P_)) . 3)
+ (,(lambda (package)
+ (and=> (package-description package) P_)) . 2)
+
(,(lambda (type)
(match (and=> (package-location type) location-file)
((? string? file) (basename file ".scm"))
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))
-(define color-table
- `((CLEAR . "0")
- (RESET . "0")
- (BOLD . "1")
- (DARK . "2")
- (UNDERLINE . "4")
- (UNDERSCORE . "4")
- (BLINK . "5")
- (REVERSE . "6")
- (CONCEALED . "8")
- (BLACK . "30")
- (RED . "31")
- (GREEN . "32")
- (YELLOW . "33")
- (BLUE . "34")
- (MAGENTA . "35")
- (CYAN . "36")
- (WHITE . "37")
- (ON-BLACK . "40")
- (ON-RED . "41")
- (ON-GREEN . "42")
- (ON-YELLOW . "43")
- (ON-BLUE . "44")
- (ON-MAGENTA . "45")
- (ON-CYAN . "46")
- (ON-WHITE . "47")))
-
-(define (color . lst)
- "Return a string containing the ANSI escape sequence for producing the
-requested set of attributes in LST. Unknown attributes are ignored."
- (let ((color-list
- (remove not
- (map (lambda (color) (assq-ref color-table color))
- lst))))
- (if (null? color-list)
- ""
- (string-append
- (string #\esc #\[)
- (string-join color-list ";" 'infix)
- "m"))))
-
-(define (colorize-string str . color-list)
- "Return a copy of STR colorized using ANSI escape sequences according to the
-attributes STR. At the end of the returned string, the color attributes will
-be reset such that subsequent output will not have any colors in effect."
- (string-append
- (apply color color-list)
- str
- (color 'RESET)))
-
;;; ui.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff