guix/ui.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   5 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix ui)
  24   #:use-module (guix utils)
  25   #:use-module (guix store)
  26   #:use-module (guix config)
  27   #:use-module (guix packages)
  28   #:use-module (guix profiles)
  29   #:use-module (guix derivations)
  30   #:use-module (guix build-system)
  31   #:use-module (guix serialization)
  32   #:use-module ((guix build utils) #:select (mkdir-p))
  33   #:use-module ((guix licenses) #:select (license? license-name))
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-11)
  36   #:use-module (srfi srfi-19)
  37   #:use-module (srfi srfi-26)
  38   #:use-module (srfi srfi-34)
  39   #:use-module (srfi srfi-35)
  40   #:use-module (srfi srfi-37)
  41   #:autoload   (ice-9 ftw)  (scandir)
  42   #:use-module (ice-9 match)
  43   #:use-module (ice-9 format)
  44   #:use-module (ice-9 regex)
  45   #:export (_
  46             N_
  47             P_
  48             report-error
  49             leave
  50             report-load-error
  51             warn-about-load-error
  52             show-version-and-exit
  53             show-bug-report-information
  54             string->number*
  55             size->number
  56             show-what-to-build
  57             show-manifest-transaction
  58             call-with-error-handling
  59             with-error-handling
  60             read/eval
  61             read/eval-package-expression
  62             location->string
  63             switch-symlinks
  64             config-directory
  65             fill-paragraph
  66             string->recutils
  67             package->recutils
  68             package-specification->name+version+output
  69             string->generations
  70             string->duration
  71             args-fold*
  72             parse-command-line
  73             run-guix-command
  74             program-name
  75             guix-warning-port
  76             warning
  77             guix-main))
  78
  79 ;;; Commentary:
  80 ;;;
  81 ;;; User interface facilities for command-line tools.
  82 ;;;
  83 ;;; Code:
  84
  85 (define %gettext-domain
  86   ;; Text domain for strings used in the tools.
  87   "guix")
  88
  89 (define %package-text-domain
  90   ;; Text domain for package synopses and descriptions.
  91   "guix-packages")
  92
  93 (define _ (cut gettext <> %gettext-domain))
  94 (define N_ (cut ngettext <> <> <> %gettext-domain))
  95 (define P_ (cut gettext <> %package-text-domain))
  96
  97 (define-syntax-rule (define-diagnostic name prefix)
  98   "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
  99 messages."
 100   (define-syntax name
 101     (lambda (x)
 102       (define (augmented-format-string fmt)
 103         (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
 104
 105       (syntax-case x ()
 106         ((name (underscore fmt) args (... ...))
 107          (and (string? (syntax->datum #'fmt))
 108               (free-identifier=? #'underscore #'_))
 109          (with-syntax ((fmt*   (augmented-format-string #'fmt))
 110                        (prefix (datum->syntax x prefix)))
 111            #'(format (guix-warning-port) (gettext fmt*)
 112                      (program-name) (program-name) prefix
 113                      args (... ...))))
 114         ((name (N-underscore singular plural n) args (... ...))
 115          (and (string? (syntax->datum #'singular))
 116               (string? (syntax->datum #'plural))
 117               (free-identifier=? #'N-underscore #'N_))
 118          (with-syntax ((s      (augmented-format-string #'singular))
 119                        (p      (augmented-format-string #'plural))
 120                        (prefix (datum->syntax x prefix)))
 121            #'(format (guix-warning-port)
 122                      (ngettext s p n %gettext-domain)
 123                      (program-name) (program-name) prefix
 124                      args (... ...))))))))
 125
 126 (define-diagnostic warning "warning: ") ; emit a warning
 127
 128 (define-diagnostic report-error "error: ")
 129 (define-syntax-rule (leave args ...)
 130   "Emit an error message and exit."
 131   (begin
 132     (report-error args ...)
 133     (exit 1)))
 134
 135 (define (report-load-error file args)
 136   "Report the failure to load FILE, a user-provided Scheme file, and exit.
 137 ARGS is the list of arguments received by the 'throw' handler."
 138   (match args
 139     (('system-error . _)
 140      (let ((err (system-error-errno args)))
 141        (leave (_ "failed to load '~a': ~a~%") file (strerror err))))
 142     (('syntax-error proc message properties form . rest)
 143      (let ((loc (source-properties->location properties)))
 144        (format (current-error-port) (_ "~a: error: ~a~%")
 145                (location->string loc) message)
 146        (exit 1)))
 147     ((error args ...)
 148      (report-error (_ "failed to load '~a':~%") file)
 149      (apply display-error #f (current-error-port) args)
 150      (exit 1))))
 151
 152 (define (warn-about-load-error file args)         ;FIXME: factorize with ↑
 153   "Report the failure to load FILE, a user-provided Scheme file, without
 154 exiting.  ARGS is the list of arguments received by the 'throw' handler."
 155   (match args
 156     (('system-error . _)
 157      (let ((err (system-error-errno args)))
 158        (warning (_ "failed to load '~a': ~a~%") file (strerror err))))
 159     (('syntax-error proc message properties form . rest)
 160      (let ((loc (source-properties->location properties)))
 161        (format (current-error-port) (_ "~a: warning: ~a~%")
 162                (location->string loc) message)))
 163     ((error args ...)
 164      (warning (_ "failed to load '~a':~%") file)
 165      (apply display-error #f (current-error-port) args))))
 166
 167 (define (install-locale)
 168   "Install the current locale settings."
 169   (catch 'system-error
 170     (lambda _
 171       (setlocale LC_ALL ""))
 172     (lambda args
 173       (warning (_ "failed to install locale: ~a~%")
 174                (strerror (system-error-errno args))))))
 175
 176 (define (initialize-guix)
 177   "Perform the usual initialization for stand-alone Guix commands."
 178   (install-locale)
 179   (textdomain %gettext-domain)
 180
 181   ;; Ignore SIGPIPE.  If the daemon closes the connection, we prefer to be
 182   ;; notified via an EPIPE later.
 183   (sigaction SIGPIPE SIG_IGN)
 184
 185   (setvbuf (current-output-port) _IOLBF)
 186   (setvbuf (current-error-port) _IOLBF))
 187
 188 (define* (show-version-and-exit #:optional (command (car (command-line))))
 189   "Display version information for COMMAND and `(exit 0)'."
 190   (simple-format #t "~a (~a) ~a~%"
 191                  command %guix-package-name %guix-version)
 192   (display (_ "Copyright (C) 2015 the Guix authors
 193 License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
 194 This is free software: you are free to change and redistribute it.
 195 There is NO WARRANTY, to the extent permitted by law.
 196 "))
 197   (exit 0))
 198
 199 (define (show-bug-report-information)
 200   (format #t (_ "
 201 Report bugs to: ~a.") %guix-bug-report-address)
 202   (format #t (_ "
 203 ~a home page: <~a>") %guix-package-name %guix-home-page-url)
 204   (display (_ "
 205 General help using GNU software: <http://www.gnu.org/gethelp/>"))
 206   (newline))
 207
 208 (define (string->number* str)
 209   "Like `string->number', but error out with an error message on failure."
 210   (or (string->number str)
 211       (leave (_ "~a: invalid number~%") str)))
 212
 213 (define (size->number str)
 214   "Convert STR, a storage measurement representation such as \"1024\" or
 215 \"1MiB\", to a number of bytes.  Raise an error if STR could not be
 216 interpreted."
 217   (define unit-pos
 218     (string-rindex str char-set:digit))
 219
 220   (define unit
 221     (and unit-pos (substring str (+ 1 unit-pos))))
 222
 223   (let* ((numstr (if unit-pos
 224                      (substring str 0 (+ 1 unit-pos))
 225                      str))
 226          (num    (string->number numstr)))
 227     (unless num
 228       (leave (_ "invalid number: ~a~%") numstr))
 229
 230     ((compose inexact->exact round)
 231      (* num
 232         (match unit
 233           ((or "KiB" "K" "k") (expt 2 10))
 234           ((or "MiB" "M")     (expt 2 20))
 235           ((or "GiB" "G")     (expt 2 30))
 236           ((or "TiB" "T")     (expt 2 40))
 237           ((or "PiB" "P")     (expt 2 50))
 238           ((or "EiB" "E")     (expt 2 60))
 239           ((or "ZiB" "Z")     (expt 2 70))
 240           ((or "YiB" "Y")     (expt 2 80))
 241           ("kB"  (expt 10 3))
 242           ("MB"  (expt 10 6))
 243           ("GB"  (expt 10 9))
 244           ("TB"  (expt 10 12))
 245           ("PB"  (expt 10 15))
 246           ("EB"  (expt 10 18))
 247           ("ZB"  (expt 10 21))
 248           ("YB"  (expt 10 24))
 249           (""    1)
 250           (_
 251            (leave (_ "unknown unit: ~a~%") unit)))))))
 252
 253 (define (call-with-error-handling thunk)
 254   "Call THUNK within a user-friendly error handler."
 255   (guard (c ((package-input-error? c)
 256              (let* ((package  (package-error-package c))
 257                     (input    (package-error-invalid-input c))
 258                     (location (package-location package))
 259                     (file     (location-file location))
 260                     (line     (location-line location))
 261                     (column   (location-column location)))
 262                (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
 263                       file line column
 264                       (package-full-name package) input)))
 265             ((package-cross-build-system-error? c)
 266              (let* ((package (package-error-package c))
 267                     (loc     (package-location package))
 268                     (system  (package-build-system package)))
 269                (leave (_ "~a: ~a: build system `~a' does not support cross builds~%")
 270                       (location->string loc)
 271                       (package-full-name package)
 272                       (build-system-name system))))
 273             ((profile-not-found-error? c)
 274              (leave (_ "profile '~a' does not exist~%")
 275                     (profile-error-profile c)))
 276             ((missing-generation-error? c)
 277              (leave (_ "generation ~a of profile '~a' does not exist~%")
 278                     (missing-generation-error-generation c)
 279                     (profile-error-profile c)))
 280             ((nar-error? c)
 281              (let ((file (nar-error-file c))
 282                    (port (nar-error-port c)))
 283                (if file
 284                    (leave (_ "corrupt input while restoring '~a' from ~s~%")
 285                           file (or (port-filename port) port))
 286                    (leave (_ "corrupt input while restoring archive from ~s~%")
 287                           (or (port-filename port) port)))))
 288             ((nix-connection-error? c)
 289              (leave (_ "failed to connect to `~a': ~a~%")
 290                     (nix-connection-error-file c)
 291                     (strerror (nix-connection-error-code c))))
 292             ((nix-protocol-error? c)
 293              ;; FIXME: Server-provided error messages aren't i18n'd.
 294              (leave (_ "build failed: ~a~%")
 295                     (nix-protocol-error-message c)))
 296             ((derivation-missing-output-error? c)
 297              (leave (_ "reference to invalid output '~a' of derivation '~a'~%")
 298                     (derivation-missing-output c)
 299                     (derivation-file-name (derivation-error-derivation c))))
 300             ((message-condition? c)
 301              ;; Normally '&message' error conditions have an i18n'd message.
 302              (leave (_ "~a~%")
 303                     (gettext (condition-message c) %gettext-domain))))
 304     ;; Catch EPIPE and the likes.
 305     (catch 'system-error
 306       thunk
 307       (lambda (key proc format-string format-args . rest)
 308         (leave (_ "~a: ~a~%") proc
 309                (apply format #f format-string format-args))))))
 310
 311 (define %guix-user-module
 312   ;; Module in which user expressions are evaluated.
 313   ;; Compute lazily to avoid circularity with (guix gexp).
 314   (delay
 315     (let ((module (make-module)))
 316       (beautify-user-module! module)
 317       ;; Use (guix gexp) so that one can use #~ & co.
 318       (module-use! module (resolve-interface '(guix gexp)))
 319       module)))
 320
 321 (define (read/eval str)
 322   "Read and evaluate STR, raising an error if something goes wrong."
 323   (let ((exp (catch #t
 324                (lambda ()
 325                  (call-with-input-string str read))
 326                (lambda args
 327                  (leave (_ "failed to read expression ~s: ~s~%")
 328                         str args)))))
 329     (catch #t
 330       (lambda ()
 331         (eval exp (force %guix-user-module)))
 332       (lambda args
 333         (leave (_ "failed to evaluate expression `~a': ~s~%")
 334                exp args)))))
 335
 336 (define (read/eval-package-expression str)
 337   "Read and evaluate STR and return the package it refers to, or exit an
 338 error."
 339   (match (read/eval str)
 340     ((? package? p) p)
 341     (_
 342      (leave (_ "expression ~s does not evaluate to a package~%")
 343             str))))
 344
 345 (define* (show-what-to-build store drv
 346                              #:key dry-run? (use-substitutes? #t))
 347   "Show what will or would (depending on DRY-RUN?) be built in realizing the
 348 derivations listed in DRV.  Return #t if there's something to build, #f
 349 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 350 available for download."
 351   (define substitutable?
 352     ;; Call 'substitutation-oracle' upfront so we don't end up launching the
 353     ;; substituter many times.  This makes a big difference, especially when
 354     ;; DRV is a long list as is the case with 'guix environment'.
 355     (if use-substitutes?
 356         (substitution-oracle store drv)
 357         (const #f)))
 358
 359   (define (built-or-substitutable? drv)
 360     (or (null? (derivation-outputs drv))
 361         (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists
 362           (or (valid-path? store out)
 363               (substitutable? out)))))
 364
 365   (let*-values (((build download)
 366                  (fold2 (lambda (drv build download)
 367                           (let-values (((b d)
 368                                         (derivation-prerequisites-to-build
 369                                          store drv
 370                                          #:substitutable? substitutable?)))
 371                             (values (append b build)
 372                                     (append d download))))
 373                         '() '()
 374                         drv))
 375                 ((build)                          ; add the DRV themselves
 376                  (delete-duplicates
 377                   (append (map derivation-file-name
 378                                (remove built-or-substitutable? drv))
 379                           (map derivation-input-path build))))
 380                 ((download)                   ; add the references of DOWNLOAD
 381                  (if use-substitutes?
 382                      (delete-duplicates
 383                       (append download
 384                               (remove (cut valid-path? store <>)
 385                                       (append-map
 386                                        substitutable-references
 387                                        (substitutable-path-info store
 388                                                                 download)))))
 389                      download)))
 390     ;; TODO: Show the installed size of DOWNLOAD.
 391     (if dry-run?
 392         (begin
 393           (format (current-error-port)
 394                   (N_ "~:[The following derivation would be built:~%~{   ~a~%~}~;~]"
 395                       "~:[The following derivations would be built:~%~{   ~a~%~}~;~]"
 396                       (length build))
 397                   (null? build) build)
 398           (format (current-error-port)
 399                   (N_ "~:[The following file would be downloaded:~%~{   ~a~%~}~;~]"
 400                       "~:[The following files would be downloaded:~%~{   ~a~%~}~;~]"
 401                       (length download))
 402                   (null? download) download))
 403         (begin
 404           (format (current-error-port)
 405                   (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
 406                       "~:[The following derivations will be built:~%~{   ~a~%~}~;~]"
 407                       (length build))
 408                   (null? build) build)
 409           (format (current-error-port)
 410                   (N_ "~:[The following file will be downloaded:~%~{   ~a~%~}~;~]"
 411                       "~:[The following files will be downloaded:~%~{   ~a~%~}~;~]"
 412                       (length download))
 413                   (null? download) download)))
 414     (pair? build)))
 415
 416 (define (right-arrow port)
 417   "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
 418 replacement if PORT is not Unicode-capable."
 419   (with-fluids ((%default-port-encoding (port-encoding port)))
 420     (let ((arrow "→"))
 421       (catch 'encoding-error
 422         (lambda ()
 423           (call-with-output-string
 424             (lambda (port)
 425               (set-port-conversion-strategy! port 'error)
 426               (display arrow port))))
 427         (lambda (key . args)
 428           "->")))))
 429
 430 (define* (show-manifest-transaction store manifest transaction
 431                                     #:key dry-run?)
 432   "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
 433   (define (package-strings name version output item)
 434     (map (lambda (name version output item)
 435            (format #f "   ~a~:[:~a~;~*~]\t~a\t~a"
 436                    name
 437                    (equal? output "out") output version
 438                    (if (package? item)
 439                        (package-output store item output)
 440                        item)))
 441          name version output item))
 442
 443   (define →                        ;an arrow that can be represented on stderr
 444     (right-arrow (current-error-port)))
 445
 446   (define (upgrade-string name old-version new-version output item)
 447     (format #f "   ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
 448             name (equal? output "out") output
 449             old-version → new-version
 450             (if (package? item)
 451                 (package-output store item output)
 452                 item)))
 453
 454   (let-values (((remove install upgrade downgrade)
 455                 (manifest-transaction-effects manifest transaction)))
 456     (match remove
 457       ((($ <manifest-entry> name version output item) ..1)
 458        (let ((len    (length name))
 459              (remove (package-strings name version output item)))
 460          (if dry-run?
 461              (format (current-error-port)
 462                      (N_ "The following package would be removed:~%~{~a~%~}~%"
 463                          "The following packages would be removed:~%~{~a~%~}~%"
 464                          len)
 465                      remove)
 466              (format (current-error-port)
 467                      (N_ "The following package will be removed:~%~{~a~%~}~%"
 468                          "The following packages will be removed:~%~{~a~%~}~%"
 469                          len)
 470                      remove))))
 471       (_ #f))
 472     (match downgrade
 473       (((($ <manifest-entry> name old-version)
 474          . ($ <manifest-entry> _ new-version output item)) ..1)
 475        (let ((len       (length name))
 476              (downgrade (map upgrade-string
 477                              name old-version new-version output item)))
 478          (if dry-run?
 479              (format (current-error-port)
 480                      (N_ "The following package would be downgraded:~%~{~a~%~}~%"
 481                          "The following packages would be downgraded:~%~{~a~%~}~%"
 482                          len)
 483                      downgrade)
 484              (format (current-error-port)
 485                      (N_ "The following package will be downgraded:~%~{~a~%~}~%"
 486                          "The following packages will be downgraded:~%~{~a~%~}~%"
 487                          len)
 488                      downgrade))))
 489       (_ #f))
 490     (match upgrade
 491       (((($ <manifest-entry> name old-version)
 492          . ($ <manifest-entry> _ new-version output item)) ..1)
 493        (let ((len     (length name))
 494              (upgrade (map upgrade-string
 495                            name old-version new-version output item)))
 496          (if dry-run?
 497              (format (current-error-port)
 498                      (N_ "The following package would be upgraded:~%~{~a~%~}~%"
 499                          "The following packages would be upgraded:~%~{~a~%~}~%"
 500                          len)
 501                      upgrade)
 502              (format (current-error-port)
 503                      (N_ "The following package will be upgraded:~%~{~a~%~}~%"
 504                          "The following packages will be upgraded:~%~{~a~%~}~%"
 505                          len)
 506                      upgrade))))
 507       (_ #f))
 508     (match install
 509       ((($ <manifest-entry> name version output item _) ..1)
 510        (let ((len     (length name))
 511              (install (package-strings name version output item)))
 512          (if dry-run?
 513              (format (current-error-port)
 514                      (N_ "The following package would be installed:~%~{~a~%~}~%"
 515                          "The following packages would be installed:~%~{~a~%~}~%"
 516                          len)
 517                      install)
 518              (format (current-error-port)
 519                      (N_ "The following package will be installed:~%~{~a~%~}~%"
 520                          "The following packages will be installed:~%~{~a~%~}~%"
 521                          len)
 522                      install))))
 523       (_ #f))))
 524
 525 (define-syntax with-error-handling
 526   (syntax-rules ()
 527     "Run BODY within a user-friendly error condition handler."
 528     ((_ body ...)
 529      (call-with-error-handling
 530       (lambda ()
 531         body ...)))))
 532
 533 (define (location->string loc)
 534   "Return a human-friendly, GNU-standard representation of LOC."
 535   (match loc
 536     (#f (_ "<unknown location>"))
 537     (($ <location> file line column)
 538      (format #f "~a:~a:~a" file line column))))
 539
 540 (define (switch-symlinks link target)
 541   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 542 both when LINK already exists and when it does not."
 543   (let ((pivot (string-append link ".new")))
 544     (symlink target pivot)
 545     (rename-file pivot link)))
 546
 547 (define (config-directory)
 548   "Return the name of the configuration directory, after making sure that it
 549 exists.  Honor the XDG specs,
 550 <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
 551   (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
 552                         (and=> (getenv "HOME")
 553                                (cut string-append <> "/.config")))
 554                     (cut string-append <> "/guix"))))
 555     (catch 'system-error
 556       (lambda ()
 557         (mkdir-p dir)
 558         dir)
 559       (lambda args
 560         (let ((err (system-error-errno args)))
 561           ;; ERR is necessarily different from EEXIST.
 562           (leave (_ "failed to create configuration directory `~a': ~a~%")
 563                  dir (strerror err)))))))
 564
 565 (define* (fill-paragraph str width #:optional (column 0))
 566   "Fill STR such that each line contains at most WIDTH characters, assuming
 567 that the first character is at COLUMN.
 568
 569 When STR contains a single line break surrounded by other characters, it is
 570 converted to a space; sequences of more than one line break are preserved."
 571   (define (maybe-break chr result)
 572     (match result
 573       ((column newlines chars)
 574        (case chr
 575          ((#\newline)
 576           `(,column ,(+ 1 newlines) ,chars))
 577          (else
 578           (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1))
 579                  (chars  (case newlines
 580                            ((0) chars)
 581                            ((1)
 582                             (append (make-list spaces #\space) chars))
 583                            (else
 584                             (append (make-list newlines #\newline) chars))))
 585                  (column (case newlines
 586                            ((0) column)
 587                            ((1) (+ spaces column))
 588                            (else 0))))
 589             (let ((chars  (cons chr chars))
 590                   (column (+ 1 column)))
 591               (if (> column width)
 592                   (let*-values (((before after)
 593                                  (break (cut eqv? #\space <>) chars))
 594                                 ((len)
 595                                  (length before)))
 596                     (if (<= len width)
 597                         `(,len
 598                           0
 599                           ,(if (null? after)
 600                                before
 601                                (append before
 602                                        (cons #\newline
 603                                              (drop-while (cut eqv? #\space <>)
 604                                                          after)))))
 605                         `(,column 0 ,chars)))     ; unbreakable
 606                   `(,column 0 ,chars)))))))))
 607
 608   (match (string-fold maybe-break
 609                       `(,column 0 ())
 610                       str)
 611     ((_ _ chars)
 612      (list->string (reverse chars)))))
 613
 614 \f
 615 ;;;
 616 ;;; Packages.
 617 ;;;
 618
 619 (define (string->recutils str)
 620   "Return a version of STR where newlines have been replaced by newlines
 621 followed by \"+ \", which makes for a valid multi-line field value in the
 622 `recutils' syntax."
 623   (list->string
 624    (string-fold-right (lambda (chr result)
 625                         (if (eqv? chr #\newline)
 626                             (cons* chr #\+ #\space result)
 627                             (cons chr result)))
 628                       '()
 629                       str)))
 630
 631 (define* (package->recutils p port
 632                             #:optional (width (or (and=> (getenv "WIDTH")
 633                                                          string->number)
 634                                                   80)))
 635   "Write to PORT a `recutils' record of package P, arranging to fit within
 636 WIDTH columns."
 637   (define (description->recutils str)
 638     (let ((str (P_ str)))
 639       (string->recutils
 640        (fill-paragraph str width
 641                        (string-length "description: ")))))
 642
 643   (define (dependencies->recutils packages)
 644     (let ((list (string-join (map package-full-name
 645                                   (sort packages package<?)) " ")))
 646       (string->recutils
 647        (fill-paragraph list width
 648                        (string-length "dependencies: ")))))
 649
 650   (define (package<? p1 p2)
 651     (string<? (package-full-name p1) (package-full-name p2)))
 652
 653   ;; Note: Don't i18n field names so that people can post-process it.
 654   (format port "name: ~a~%" (package-name p))
 655   (format port "version: ~a~%" (package-version p))
 656   (format port "dependencies: ~a~%"
 657           (match (package-direct-inputs p)
 658             (((labels inputs . _) ...)
 659              (dependencies->recutils (filter package? inputs)))))
 660   (format port "location: ~a~%"
 661           (or (and=> (package-location p) location->string)
 662               (_ "unknown")))
 663
 664   ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
 665   ;; field identifiers.
 666   (format port "homepage: ~a~%" (package-home-page p))
 667
 668   (format port "license: ~a~%"
 669           (match (package-license p)
 670             (((? license? licenses) ...)
 671              (string-join (map license-name licenses)
 672                           ", "))
 673             ((? license? license)
 674              (license-name license))
 675             (x
 676              (_ "unknown"))))
 677   (format port "synopsis: ~a~%"
 678           (string-map (match-lambda
 679                        (#\newline #\space)
 680                        (chr       chr))
 681                       (or (and=> (package-synopsis p) P_)
 682                           "")))
 683   (format port "description: ~a~%"
 684           (and=> (package-description p) description->recutils))
 685   (newline port))
 686
 687 (define (string->generations str)
 688   "Return the list of generations matching a pattern in STR.  This function
 689 accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
 690   (define (maybe-integer)
 691     (let ((x (string->number str)))
 692       (and (integer? x)
 693            x)))
 694
 695   (define (maybe-comma-separated-integers)
 696     (let ((lst (delete-duplicates
 697                 (map string->number
 698                      (string-split str #\,)))))
 699       (and (every integer? lst)
 700            lst)))
 701
 702   (cond ((maybe-integer)
 703          =>
 704          list)
 705         ((maybe-comma-separated-integers)
 706          =>
 707          identity)
 708         ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
 709          =>
 710          (lambda (match)
 711            (let ((s (string->number (match:substring match 1)))
 712                  (e (string->number (match:substring match 2))))
 713              (and (every integer? (list s e))
 714                   (<= s e)
 715                   (iota (1+ (- e s)) s)))))
 716         ((string-match "^([0-9]+)\\.\\.$" str)
 717          =>
 718          (lambda (match)
 719            (let ((s (string->number (match:substring match 1))))
 720              (and (integer? s)
 721                   `(>= ,s)))))
 722         ((string-match "^\\.\\.([0-9]+)$" str)
 723          =>
 724          (lambda (match)
 725            (let ((e (string->number (match:substring match 1))))
 726              (and (integer? e)
 727                   `(<= ,e)))))
 728         (else #f)))
 729
 730 (define (string->duration str)
 731   "Return the duration matching a pattern in STR.  This function accepts the
 732 following patterns: \"1d\", \"1w\", \"1m\"."
 733   (define (hours->duration hours match)
 734     (make-time time-duration 0
 735                (* 3600 hours (string->number (match:substring match 1)))))
 736
 737   (cond ((string-match "^([0-9]+)d$" str)
 738          =>
 739          (lambda (match)
 740            (hours->duration 24 match)))
 741         ((string-match "^([0-9]+)w$" str)
 742          =>
 743          (lambda (match)
 744            (hours->duration (* 24 7) match)))
 745         ((string-match "^([0-9]+)m$" str)
 746          =>
 747          (lambda (match)
 748            (hours->duration (* 24 30) match)))
 749         (else #f)))
 750
 751 (define* (package-specification->name+version+output spec
 752                                                      #:optional (output "out"))
 753   "Parse package specification SPEC and return three value: the specified
 754 package name, version number (or #f), and output name (or OUTPUT).  SPEC may
 755 optionally contain a version number and an output name, as in these examples:
 756
 757   guile
 758   guile-2.0.9
 759   guile:debug
 760   guile-2.0.9:debug
 761 "
 762   (let*-values (((name sub-drv)
 763                  (match (string-rindex spec #\:)
 764                    (#f    (values spec output))
 765                    (colon (values (substring spec 0 colon)
 766                                   (substring spec (+ 1 colon))))))
 767                 ((name version)
 768                  (package-name->name+version name)))
 769     (values name version sub-drv)))
 770
 771 \f
 772 ;;;
 773 ;;; Command-line option processing.
 774 ;;;
 775
 776 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
 777   "A wrapper on top of `args-fold' that does proper user-facing error
 778 reporting."
 779   (catch 'misc-error
 780     (lambda ()
 781       (apply args-fold options unrecognized-option-proc
 782              operand-proc seeds))
 783     (lambda (key proc msg args . rest)
 784       ;; XXX: MSG is not i18n'd.
 785       (leave (_ "invalid argument: ~a~%")
 786              (apply format #f msg args)))))
 787
 788 (define (environment-build-options)
 789   "Return additional build options passed as environment variables."
 790   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
 791
 792 (define %default-argument-handler
 793   ;; The default handler for non-option command-line arguments.
 794   (lambda (arg result)
 795     (alist-cons 'argument arg result)))
 796
 797 (define* (parse-command-line args options seeds
 798                              #:key
 799                              (argument-handler %default-argument-handler))
 800   "Parse the command-line arguments ARGS as well as arguments passed via the
 801 'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
 802 SRFI-37 options) and return the result, seeded by SEEDS.
 803 Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
 804
 805 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
 806 parameter of 'args-fold'."
 807   (define (parse-options-from args seeds)
 808     ;; Actual parsing takes place here.
 809     (apply args-fold* args options
 810            (lambda (opt name arg . rest)
 811              (leave (_ "~A: unrecognized option~%") name))
 812            argument-handler
 813            seeds))
 814
 815   (call-with-values
 816       (lambda ()
 817         (parse-options-from (environment-build-options) seeds))
 818     (lambda seeds
 819       ;; ARGS take precedence over what the environment variable specifies.
 820       (parse-options-from args seeds))))
 821
 822 (define (show-guix-usage)
 823   (format (current-error-port)
 824           (_ "Try `guix --help' for more information.~%"))
 825   (exit 1))
 826
 827 (define (command-files)
 828   "Return the list of source files that define Guix sub-commands."
 829   (define directory
 830     (and=> (search-path %load-path "guix.scm")
 831            (compose (cut string-append <> "/guix/scripts")
 832                     dirname)))
 833
 834   (define dot-scm?
 835     (cut string-suffix? ".scm" <>))
 836
 837   ;; In Guile 2.0.5 `scandir' would return "." and ".." regardless even though
 838   ;; they don't match `dot-scm?'.  Work around it by doing additional
 839   ;; filtering.
 840   (if directory
 841       (filter dot-scm? (scandir directory dot-scm?))
 842       '()))
 843
 844 (define (commands)
 845   "Return the list of Guix command names."
 846   (map (compose (cut string-drop-right <> 4)
 847                 basename)
 848        (command-files)))
 849
 850 (define (show-guix-help)
 851   (define (internal? command)
 852     (member command '("substitute" "authenticate" "offload")))
 853
 854   (format #t (_ "Usage: guix COMMAND ARGS...
 855 Run COMMAND with ARGS.\n"))
 856   (newline)
 857   (format #t (_ "COMMAND must be one of the sub-commands listed below:\n"))
 858   (newline)
 859   ;; TODO: Display a synopsis of each command.
 860   (format #t "~{   ~a~%~}" (sort (remove internal? (commands))
 861                                  string<?))
 862   (show-bug-report-information))
 863
 864 (define program-name
 865   ;; Name of the command-line program currently executing, or #f.
 866   (make-parameter #f))
 867
 868 (define (run-guix-command command . args)
 869   "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
 870 found."
 871   (define module
 872     (catch 'misc-error
 873       (lambda ()
 874         (resolve-interface `(guix scripts ,command)))
 875       (lambda -
 876         (format (current-error-port)
 877                 (_ "guix: ~a: command not found~%") command)
 878         (show-guix-usage))))
 879
 880   (let ((command-main (module-ref module
 881                                   (symbol-append 'guix- command))))
 882     (parameterize ((program-name command))
 883       (apply command-main args))))
 884
 885 (define guix-warning-port
 886   (make-parameter (current-warning-port)))
 887
 888 (define (guix-main arg0 . args)
 889   (initialize-guix)
 890   (let ()
 891     (define (option? str) (string-prefix? "-" str))
 892     (match args
 893       (()
 894        (format (current-error-port)
 895                (_ "guix: missing command name~%"))
 896        (show-guix-usage))
 897       ((or ("-h") ("--help"))
 898        (show-guix-help))
 899       (("--version")
 900        (show-version-and-exit "guix"))
 901       (((? option? o) args ...)
 902        (format (current-error-port)
 903                (_ "guix: unrecognized option '~a'~%") o)
 904        (show-guix-usage))
 905       (("help" args ...)
 906        (show-guix-help))
 907       ((command args ...)
 908        (apply run-guix-command
 909               (string->symbol command)
 910               args)))))
 911
 912 ;;; ui.scm ends here