emacs/guix-main.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 Alex Kost <alezost@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; Commentary:
  20
  21 ;; Information about packages and generations is passed to the elisp
  22 ;; side in the form of alists of parameters (such as ‘name’ or
  23 ;; ‘version’) and their values.
  24
  25 ;; ‘entries’ procedure is the “entry point” for the elisp side to get
  26 ;; information about packages and generations.
  27
  28 ;; Since name/version pair is not necessarily unique, we use
  29 ;; `object-address' to identify a package (for ‘id’ parameter), if
  30 ;; possible.  However for the obsolete packages (that can be found in
  31 ;; installed manifest but not in a package directory), ‘id’ parameter is
  32 ;; still "name-version" string.  So ‘id’ package parameter in the code
  33 ;; below is either an object-address number or a full-name string.
  34
  35 ;;; Code:
  36
  37 (use-modules
  38  (ice-9 vlist)
  39  (ice-9 match)
  40  (ice-9 popen)
  41  (srfi srfi-1)
  42  (srfi srfi-2)
  43  (srfi srfi-11)
  44  (srfi srfi-19)
  45  (srfi srfi-26)
  46  (guix)
  47  (guix combinators)
  48  (guix git-download)
  49  (guix packages)
  50  (guix profiles)
  51  (guix licenses)
  52  (guix utils)
  53  (guix ui)
  54  (guix scripts)
  55  (guix scripts package)
  56  (gnu packages)
  57  (gnu system))
  58
  59 (define-syntax-rule (first-or-false lst)
  60   (and (not (null? lst))
  61        (first lst)))
  62
  63 (define (list-maybe obj)
  64   (if (list? obj) obj (list obj)))
  65
  66 (define (output+error thunk)
  67   "Call THUNK and return 2 values: output and error output as strings."
  68   (let ((output-port (open-output-string))
  69         (error-port  (open-output-string)))
  70     (with-output-to-port output-port
  71       (lambda () (with-error-to-port error-port thunk)))
  72     (let ((strings (list (get-output-string output-port)
  73                          (get-output-string error-port))))
  74       (close-output-port output-port)
  75       (close-output-port error-port)
  76       (apply values strings))))
  77
  78 (define (full-name->name+version spec)
  79   "Given package specification SPEC with or without output,
  80 return two values: name and version.  For example, for SPEC
  81 \"foo@0.9.1b:lib\", return \"foo\" and \"0.9.1b\"."
  82   (let-values (((name version output)
  83                 (package-specification->name+version+output spec)))
  84     (values name version)))
  85
  86 (define (name+version->full-name name version)
  87   (string-append name "@" version))
  88
  89 (define* (make-package-specification name #:optional version output)
  90   (let ((full-name (if version
  91                        (name+version->full-name name version)
  92                        name)))
  93     (if output
  94         (string-append full-name ":" output)
  95         full-name)))
  96
  97 (define (manifest-entry->name+version+output entry)
  98   (values
  99    (manifest-entry-name    entry)
 100    (manifest-entry-version entry)
 101    (manifest-entry-output  entry)))
 102
 103 (define (manifest-entry->package-specification entry)
 104   (call-with-values
 105       (lambda () (manifest-entry->name+version+output entry))
 106     make-package-specification))
 107
 108 (define (manifest-entries->package-specifications entries)
 109   (map manifest-entry->package-specification entries))
 110
 111 (define (profile-package-specifications profile)
 112   "Return a list of package specifications for PROFILE."
 113   (let ((manifest (profile-manifest profile)))
 114     (manifest-entries->package-specifications
 115      (manifest-entries manifest))))
 116
 117 (define (profile->specifications+paths profile)
 118   "Return a list of package specifications and paths for PROFILE.
 119 Each element of the list is a list of the package specification and its path."
 120   (let ((manifest (profile-manifest profile)))
 121     (map (lambda (entry)
 122            (list (manifest-entry->package-specification entry)
 123                  (manifest-entry-item entry)))
 124          (manifest-entries manifest))))
 125
 126 (define (profile-difference profile1 profile2)
 127   "Return a list of package specifications for outputs installed in PROFILE1
 128 and not installed in PROFILE2."
 129   (let ((specs1 (profile-package-specifications profile1))
 130         (specs2 (profile-package-specifications profile2)))
 131     (lset-difference string=? specs1 specs2)))
 132
 133 (define (manifest-entries->hash-table entries)
 134   "Return a hash table of name keys and lists of matching manifest ENTRIES."
 135   (let ((table (make-hash-table (length entries))))
 136     (for-each (lambda (entry)
 137                 (let* ((key (manifest-entry-name entry))
 138                        (ref (hash-ref table key)))
 139                   (hash-set! table key
 140                              (if ref (cons entry ref) (list entry)))))
 141               entries)
 142     table))
 143
 144 (define (manifest=? m1 m2)
 145   (or (eq? m1 m2)
 146       (equal? m1 m2)))
 147
 148 (define manifest->hash-table
 149   (let ((current-manifest #f)
 150         (current-table #f))
 151     (lambda (manifest)
 152       "Return a hash table of name keys and matching MANIFEST entries."
 153       (unless (manifest=? manifest current-manifest)
 154         (set! current-manifest manifest)
 155         (set! current-table (manifest-entries->hash-table
 156                              (manifest-entries manifest))))
 157       current-table)))
 158
 159 (define* (manifest-entries-by-name manifest name #:optional version output)
 160   "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT."
 161   (let ((entries (or (hash-ref (manifest->hash-table manifest) name)
 162                      '())))
 163     (if (or version output)
 164         (filter (lambda (entry)
 165                   (and (or (not version)
 166                            (equal? version (manifest-entry-version entry)))
 167                        (or (not output)
 168                            (equal? output  (manifest-entry-output entry)))))
 169                 entries)
 170         entries)))
 171
 172 (define (manifest-entry-by-output entries output)
 173   "Return a manifest entry from ENTRIES matching OUTPUT."
 174   (find (lambda (entry)
 175           (string= output (manifest-entry-output entry)))
 176         entries))
 177
 178 (define (fold-manifest-by-name manifest proc init)
 179   "Fold over MANIFEST entries.
 180 Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value
 181 of RESULT.  ENTRIES is a list of manifest entries with NAME/VERSION."
 182   (hash-fold (lambda (name entries res)
 183                (proc name (manifest-entry-version (car entries))
 184                      entries res))
 185              init
 186              (manifest->hash-table manifest)))
 187
 188 (define* (object-transformer param-alist #:optional (params '()))
 189   "Return procedure transforming objects into alist of parameter/value pairs.
 190
 191 PARAM-ALIST is alist of available parameters (symbols) and procedures
 192 returning values of these parameters.  Each procedure is applied to
 193 objects.
 194
 195 PARAMS is list of parameters from PARAM-ALIST that should be returned by
 196 a resulting procedure.  If PARAMS is not specified or is an empty list,
 197 use all available parameters.
 198
 199 Example:
 200
 201   (let* ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
 202          (number->alist (object-transformer alist '(plus1 mul2))))
 203     (number->alist 8))
 204   =>
 205   ((plus1 . 9) (mul2 . 16))
 206 "
 207   (let* ((use-all-params (null? params))
 208          (alist (filter-map (match-lambda
 209                              ((param . proc)
 210                               (and (or use-all-params
 211                                        (memq param params))
 212                                    (cons param proc)))
 213                              (_ #f))
 214                             param-alist)))
 215     (lambda objects
 216       (map (match-lambda
 217             ((param . proc)
 218              (cons param (apply proc objects))))
 219            alist))))
 220
 221 (define %manifest-entry-param-alist
 222   `((output       . ,manifest-entry-output)
 223     (path         . ,manifest-entry-item)
 224     (dependencies . ,manifest-entry-dependencies)))
 225
 226 (define manifest-entry->sexp
 227   (object-transformer %manifest-entry-param-alist))
 228
 229 (define (manifest-entries->sexps entries)
 230   (map manifest-entry->sexp entries))
 231
 232 (define (package-inputs-names inputs)
 233   "Return a list of full names of the packages from package INPUTS."
 234   (filter-map (match-lambda
 235                ((_ (? package? package))
 236                 (make-package-specification (package-name package)
 237                                             (package-version package)))
 238                ((_ (? package? package) output)
 239                 (make-package-specification (package-name package)
 240                                             (package-version package)
 241                                             output))
 242                (_ #f))
 243               inputs))
 244
 245 (define (package-license-names package)
 246   "Return a list of license names of the PACKAGE."
 247   (filter-map (lambda (license)
 248                 (and (license? license)
 249                      (license-name license)))
 250               (list-maybe (package-license package))))
 251
 252 (define (package-source-names package)
 253   "Return a list of source names (URLs) of the PACKAGE."
 254   (let ((source (package-source package)))
 255     (and (origin? source)
 256          (filter-map (lambda (uri)
 257                        (cond ((string? uri)
 258                               uri)
 259                              ((git-reference? uri)
 260                               (git-reference-url uri))
 261                              (else "Unknown source type")))
 262                      (list-maybe (origin-uri source))))))
 263
 264 (define (package-unique? package)
 265   "Return #t if PACKAGE is a single package with such name/version."
 266   (match (packages-by-name (package-name package)
 267                            (package-version package))
 268     ((package) #t)
 269     (_ #f)))
 270
 271 (define %package-param-alist
 272   `((id                . ,object-address)
 273     (package-id        . ,object-address)
 274     (name              . ,package-name)
 275     (version           . ,package-version)
 276     (license           . ,package-license-names)
 277     (source            . ,package-source-names)
 278     (synopsis          . ,package-synopsis)
 279     (description       . ,package-description-string)
 280     (home-url          . ,package-home-page)
 281     (outputs           . ,package-outputs)
 282     (systems           . ,package-supported-systems)
 283     (non-unique        . ,(negate package-unique?))
 284     (inputs            . ,(lambda (pkg)
 285                             (package-inputs-names
 286                              (package-inputs pkg))))
 287     (native-inputs     . ,(lambda (pkg)
 288                             (package-inputs-names
 289                              (package-native-inputs pkg))))
 290     (propagated-inputs . ,(lambda (pkg)
 291                             (package-inputs-names
 292                              (package-propagated-inputs pkg))))
 293     (location          . ,(lambda (pkg)
 294                             (location->string (package-location pkg))))))
 295
 296 (define (package-param package param)
 297   "Return a value of a PACKAGE PARAM."
 298   (and=> (assq-ref %package-param-alist param)
 299          (cut <> package)))
 300
 301 \f
 302 ;;; Finding packages.
 303
 304 (define-values (package-by-address
 305                 register-package)
 306   (let ((table (delay (fold-packages
 307                        (lambda (package table)
 308                          (vhash-consq (object-address package)
 309                                       package table))
 310                        vlist-null))))
 311     (values
 312      (lambda (address)
 313        "Return package by its object ADDRESS."
 314        (match (vhash-assq address (force table))
 315          ((_ . package) package)
 316          (_ #f)))
 317      (lambda (package)
 318        "Register PACKAGE by its 'object-address', so that later
 319 'package-by-address' can be used to access it."
 320        (let ((table* (force table)))
 321          (set! table
 322                (delay (vhash-consq (object-address package)
 323                                    package table*))))))))
 324
 325 (define packages-by-name+version
 326   (let ((table (delay (fold-packages
 327                        (lambda (package table)
 328                          (let ((file (location-file
 329                                       (package-location package))))
 330                            (vhash-cons (cons (package-name package)
 331                                              (package-version package))
 332                                        package table)))
 333                        vlist-null))))
 334     (lambda (name version)
 335       "Return packages matching NAME and VERSION."
 336       (vhash-fold* cons '() (cons name version) (force table)))))
 337
 338 (define (packages-by-full-name full-name)
 339   (call-with-values
 340       (lambda () (full-name->name+version full-name))
 341     packages-by-name+version))
 342
 343 (define (packages-by-id id)
 344   (if (integer? id)
 345       (let ((pkg (package-by-address id)))
 346         (if pkg (list pkg) '()))
 347       (packages-by-full-name id)))
 348
 349 (define (id->name+version id)
 350   (if (integer? id)
 351       (and=> (package-by-address id)
 352              (lambda (pkg)
 353                (values (package-name pkg)
 354                        (package-version pkg))))
 355       (full-name->name+version id)))
 356
 357 (define (package-by-id id)
 358   (first-or-false (packages-by-id id)))
 359
 360 (define (newest-package-by-id id)
 361   (and=> (id->name+version id)
 362          (lambda (name)
 363            (first-or-false (find-best-packages-by-name name #f)))))
 364
 365 (define (matching-packages predicate)
 366   (fold-packages (lambda (pkg res)
 367                    (if (predicate pkg)
 368                        (cons pkg res)
 369                        res))
 370                  '()))
 371
 372 (define (filter-packages-by-output packages output)
 373   (filter (lambda (package)
 374             (member output (package-outputs package)))
 375           packages))
 376
 377 (define* (packages-by-name name #:optional version output)
 378   "Return a list of packages matching NAME, VERSION and OUTPUT."
 379   (let ((packages (if version
 380                       (packages-by-name+version name version)
 381                       (matching-packages
 382                        (lambda (pkg) (string=? name (package-name pkg)))))))
 383     (if output
 384         (filter-packages-by-output packages output)
 385         packages)))
 386
 387 (define (manifest-entry->packages entry)
 388   (call-with-values
 389       (lambda () (manifest-entry->name+version+output entry))
 390     packages-by-name))
 391
 392 (define (packages-by-regexp regexp match-params)
 393   "Return a list of packages matching REGEXP string.
 394 MATCH-PARAMS is a list of parameters that REGEXP can match."
 395   (define (package-match? package regexp)
 396     (any (lambda (param)
 397            (let ((val (package-param package param)))
 398              (and (string? val) (regexp-exec regexp val))))
 399          match-params))
 400
 401   (let ((re (make-regexp regexp regexp/icase)))
 402     (matching-packages (cut package-match? <> re))))
 403
 404 (define (packages-by-license license)
 405   "Return a list of packages with LICENSE."
 406   (matching-packages
 407    (lambda (package)
 408      (memq license (list-maybe (package-license package))))))
 409
 410 (define (all-available-packages)
 411   "Return a list of all available packages."
 412   (matching-packages (const #t)))
 413
 414 (define (newest-available-packages)
 415   "Return a list of the newest available packages."
 416   (vhash-fold (lambda (name elem res)
 417                 (match elem
 418                   ((_ newest pkgs ...)
 419                    (cons newest res))))
 420               '()
 421               (find-newest-available-packages)))
 422
 423 (define (packages-from-file file)
 424   "Return a list of packages from FILE."
 425   (let ((package (load (canonicalize-path file))))
 426     (if (package? package)
 427         (begin
 428           (register-package package)
 429           (list package))
 430         '())))
 431
 432 \f
 433 ;;; Making package/output patterns.
 434
 435 (define (specification->package-pattern specification)
 436   (call-with-values
 437       (lambda ()
 438         (full-name->name+version specification))
 439     list))
 440
 441 (define (specification->output-pattern specification)
 442   (call-with-values
 443       (lambda ()
 444         (package-specification->name+version+output specification #f))
 445     list))
 446
 447 (define (id->package-pattern id)
 448   (if (integer? id)
 449       (package-by-address id)
 450       (specification->package-pattern id)))
 451
 452 (define (id->output-pattern id)
 453   "Return an output pattern by output ID.
 454 ID should be '<package-address>:<output>' or '<name>-<version>:<output>'."
 455   (let-values (((name version output)
 456                 (package-specification->name+version+output id)))
 457     (if version
 458         (list name version output)
 459         (list (package-by-address (string->number name))
 460               output))))
 461
 462 (define (specifications->package-patterns . specifications)
 463   (map specification->package-pattern specifications))
 464
 465 (define (specifications->output-patterns . specifications)
 466   (map specification->output-pattern specifications))
 467
 468 (define (ids->package-patterns . ids)
 469   (map id->package-pattern ids))
 470
 471 (define (ids->output-patterns . ids)
 472   (map id->output-pattern ids))
 473
 474 (define* (manifest-patterns-result packages res obsolete-pattern
 475                                    #:optional installed-pattern)
 476   "Auxiliary procedure for 'manifest-package-patterns' and
 477 'manifest-output-patterns'."
 478   (if (null? packages)
 479       (cons (obsolete-pattern) res)
 480       (if installed-pattern
 481           ;; We don't need duplicates for a list of installed packages,
 482           ;; so just take any (car) package.
 483           (cons (installed-pattern (car packages)) res)
 484           res)))
 485
 486 (define* (manifest-package-patterns manifest #:optional obsolete-only?)
 487   "Return a list of package patterns for MANIFEST entries.
 488 If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
 489 for obsolete packages."
 490   (fold-manifest-by-name
 491    manifest
 492    (lambda (name version entries res)
 493      (manifest-patterns-result (packages-by-name name version)
 494                                res
 495                                (lambda () (list name version entries))
 496                                (and (not obsolete-only?)
 497                                     (cut list <> entries))))
 498    '()))
 499
 500 (define* (manifest-output-patterns manifest #:optional obsolete-only?)
 501   "Return a list of output patterns for MANIFEST entries.
 502 If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
 503 for obsolete packages."
 504   (fold (lambda (entry res)
 505           (manifest-patterns-result (manifest-entry->packages entry)
 506                                     res
 507                                     (lambda () entry)
 508                                     (and (not obsolete-only?)
 509                                          (cut list <> entry))))
 510         '()
 511         (manifest-entries manifest)))
 512
 513 (define (obsolete-package-patterns manifest)
 514   (manifest-package-patterns manifest #t))
 515
 516 (define (obsolete-output-patterns manifest)
 517   (manifest-output-patterns manifest #t))
 518
 519 \f
 520 ;;; Transforming package/output patterns into alists.
 521
 522 (define (obsolete-package-sexp name version entries)
 523   "Return an alist with information about obsolete package.
 524 ENTRIES is a list of installed manifest entries."
 525   `((id        . ,(name+version->full-name name version))
 526     (name      . ,name)
 527     (version   . ,version)
 528     (outputs   . ,(map manifest-entry-output entries))
 529     (obsolete  . #t)
 530     (installed . ,(manifest-entries->sexps entries))))
 531
 532 (define (package-pattern-transformer manifest params)
 533   "Return 'package-pattern->package-sexps' procedure."
 534   (define package->sexp
 535     (object-transformer %package-param-alist params))
 536
 537   (define* (sexp-by-package package #:optional
 538                             (entries (manifest-entries-by-name
 539                                       manifest
 540                                       (package-name package)
 541                                       (package-version package))))
 542     (cons (cons 'installed (manifest-entries->sexps entries))
 543           (package->sexp package)))
 544
 545   (define (->sexps pattern)
 546     (match pattern
 547       ((? package? package)
 548        (list (sexp-by-package package)))
 549       (((? package? package) entries)
 550        (list (sexp-by-package package entries)))
 551       ((name version entries)
 552        (list (obsolete-package-sexp
 553               name version entries)))
 554       ((name version)
 555        (let ((packages (packages-by-name name version)))
 556          (if (null? packages)
 557              (let ((entries (manifest-entries-by-name
 558                              manifest name version)))
 559                (if (null? entries)
 560                    '()
 561                    (list (obsolete-package-sexp
 562                           name version entries))))
 563              (map sexp-by-package packages))))
 564       (_ '())))
 565
 566   ->sexps)
 567
 568 (define (output-pattern-transformer manifest params)
 569   "Return 'output-pattern->output-sexps' procedure."
 570   (define package->sexp
 571     (object-transformer (alist-delete 'id %package-param-alist)
 572                         params))
 573
 574   (define manifest-entry->sexp
 575     (object-transformer (alist-delete 'output %manifest-entry-param-alist)
 576                         params))
 577
 578   (define* (output-sexp pkg-alist pkg-address output
 579                         #:optional entry)
 580     (let ((entry-alist (if entry
 581                            (manifest-entry->sexp entry)
 582                            '()))
 583           (base `((id        . ,(string-append
 584                                  (number->string pkg-address)
 585                                  ":" output))
 586                   (output    . ,output)
 587                   (installed . ,(->bool entry)))))
 588       (append entry-alist base pkg-alist)))
 589
 590   (define (obsolete-output-sexp entry)
 591     (let-values (((name version output)
 592                   (manifest-entry->name+version+output entry)))
 593       (let ((base `((id         . ,(make-package-specification
 594                                     name version output))
 595                     (package-id . ,(name+version->full-name name version))
 596                     (name       . ,name)
 597                     (version    . ,version)
 598                     (output     . ,output)
 599                     (obsolete   . #t)
 600                     (installed  . #t))))
 601         (append (manifest-entry->sexp entry) base))))
 602
 603   (define* (sexps-by-package package #:optional output
 604                              (entries (manifest-entries-by-name
 605                                        manifest
 606                                        (package-name package)
 607                                        (package-version package))))
 608     ;; Assuming that PACKAGE has this OUTPUT.
 609     (let ((pkg-alist (package->sexp package))
 610           (address (object-address package))
 611           (outputs (if output
 612                        (list output)
 613                        (package-outputs package))))
 614       (map (lambda (output)
 615              (output-sexp pkg-alist address output
 616                           (manifest-entry-by-output entries output)))
 617            outputs)))
 618
 619   (define* (sexps-by-manifest-entry entry #:optional
 620                                     (packages (manifest-entry->packages
 621                                                entry)))
 622     (if (null? packages)
 623         (list (obsolete-output-sexp entry))
 624         (map (lambda (package)
 625                (output-sexp (package->sexp package)
 626                             (object-address package)
 627                             (manifest-entry-output entry)
 628                             entry))
 629              packages)))
 630
 631   (define (->sexps pattern)
 632     (match pattern
 633       ((? package? package)
 634        (sexps-by-package package))
 635       ((package (? string? output))
 636        (sexps-by-package package output))
 637       ((? manifest-entry? entry)
 638        (list (obsolete-output-sexp entry)))
 639       ((package entry)
 640        (sexps-by-manifest-entry entry (list package)))
 641       ((name version output)
 642        (let ((packages (packages-by-name name version output)))
 643          (if (null? packages)
 644              (let ((entries (manifest-entries-by-name
 645                              manifest name version output)))
 646                (append-map (cut sexps-by-manifest-entry <>)
 647                            entries))
 648              (append-map (cut sexps-by-package <> output)
 649                          packages))))
 650       (_ '())))
 651
 652   ->sexps)
 653
 654 (define (entry-type-error entry-type)
 655   (error (format #f "Wrong entry-type '~a'" entry-type)))
 656
 657 (define (search-type-error entry-type search-type)
 658   (error (format #f "Wrong search type '~a' for entry-type '~a'"
 659                  search-type entry-type)))
 660
 661 (define %pattern-transformers
 662   `((package . ,package-pattern-transformer)
 663     (output  . ,output-pattern-transformer)))
 664
 665 (define (pattern-transformer entry-type)
 666   (assq-ref %pattern-transformers entry-type))
 667
 668 ;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS)
 669 ;; as arguments; see `package/output-sexps'.
 670 (define %patterns-makers
 671   (let* ((apply-to-rest         (lambda (proc)
 672                                   (lambda (_ . rest) (apply proc rest))))
 673          (apply-to-first        (lambda (proc)
 674                                   (lambda (first . _) (proc first))))
 675          (manifest-package-proc (apply-to-first manifest-package-patterns))
 676          (manifest-output-proc  (apply-to-first manifest-output-patterns))
 677          (regexp-proc           (lambda (_ regexp params . __)
 678                                   (packages-by-regexp regexp params)))
 679          (license-proc          (lambda (_ license-name)
 680                                   (packages-by-license
 681                                    (lookup-license license-name))))
 682          (location-proc         (lambda (_ location)
 683                                   (packages-by-location-file location)))
 684          (file-proc             (lambda (_ file)
 685                                   (packages-from-file file)))
 686          (all-proc              (lambda _ (all-available-packages)))
 687          (newest-proc           (lambda _ (newest-available-packages))))
 688     `((package
 689        (id               . ,(apply-to-rest ids->package-patterns))
 690        (name             . ,(apply-to-rest specifications->package-patterns))
 691        (installed        . ,manifest-package-proc)
 692        (obsolete         . ,(apply-to-first obsolete-package-patterns))
 693        (regexp           . ,regexp-proc)
 694        (license          . ,license-proc)
 695        (location         . ,location-proc)
 696        (from-file        . ,file-proc)
 697        (all-available    . ,all-proc)
 698        (newest-available . ,newest-proc))
 699       (output
 700        (id               . ,(apply-to-rest ids->output-patterns))
 701        (name             . ,(apply-to-rest specifications->output-patterns))
 702        (installed        . ,manifest-output-proc)
 703        (obsolete         . ,(apply-to-first obsolete-output-patterns))
 704        (regexp           . ,regexp-proc)
 705        (license          . ,license-proc)
 706        (location         . ,location-proc)
 707        (from-file        . ,file-proc)
 708        (all-available    . ,all-proc)
 709        (newest-available . ,newest-proc)))))
 710
 711 (define (patterns-maker entry-type search-type)
 712   (or (and=> (assq-ref %patterns-makers entry-type)
 713              (cut assq-ref <> search-type))
 714       (search-type-error entry-type search-type)))
 715
 716 (define (package/output-sexps profile params entry-type
 717                               search-type search-vals)
 718   "Return information about packages or package outputs.
 719 See 'entry-sexps' for details."
 720   (let* ((manifest (profile-manifest profile))
 721          (patterns (if (and (eq? entry-type 'output)
 722                             (eq? search-type 'profile-diff))
 723                        (match search-vals
 724                          ((p1 p2)
 725                           (map specification->output-pattern
 726                                (profile-difference p1 p2)))
 727                          (_ '()))
 728                        (apply (patterns-maker entry-type search-type)
 729                               manifest search-vals)))
 730          (->sexps ((pattern-transformer entry-type) manifest params)))
 731     (append-map ->sexps patterns)))
 732
 733 \f
 734 ;;; Getting information about generations.
 735
 736 (define (generation-param-alist profile)
 737   "Return an alist of generation parameters and procedures for PROFILE."
 738   (let ((current (generation-number profile)))
 739     `((id          . ,identity)
 740       (number      . ,identity)
 741       (prev-number . ,(cut previous-generation-number profile <>))
 742       (current     . ,(cut = current <>))
 743       (path        . ,(cut generation-file-name profile <>))
 744       (time        . ,(lambda (gen)
 745                         (time-second (generation-time profile gen)))))))
 746
 747 (define (matching-generations profile predicate)
 748   "Return a list of PROFILE generations matching PREDICATE."
 749   (filter predicate (profile-generations profile)))
 750
 751 (define (last-generations profile number)
 752   "Return a list of last NUMBER generations.
 753 If NUMBER is 0 or less, return all generations."
 754   (let ((generations (profile-generations profile))
 755         (number (if (<= number 0) +inf.0 number)))
 756     (if (> (length generations) number)
 757         (list-head  (reverse generations) number)
 758         generations)))
 759
 760 (define (find-generations profile search-type search-vals)
 761   "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS."
 762   (case search-type
 763     ((id)
 764      (matching-generations profile (cut memq <> search-vals)))
 765     ((last)
 766      (last-generations profile (car search-vals)))
 767     ((all)
 768      (last-generations profile +inf.0))
 769     ((time)
 770      (match search-vals
 771        ((from to)
 772         (matching-generations
 773          profile
 774          (lambda (gen)
 775            (let ((time (time-second (generation-time profile gen))))
 776              (< from time to)))))
 777        (_ '())))
 778     (else (search-type-error "generation" search-type))))
 779
 780 (define (generation-sexps profile params search-type search-vals)
 781   "Return information about generations.
 782 See 'entry-sexps' for details."
 783   (let ((generations (find-generations profile search-type search-vals))
 784         (->sexp (object-transformer (generation-param-alist profile)
 785                                     params)))
 786     (map ->sexp generations)))
 787
 788 (define system-generation-boot-parameters
 789   (memoize
 790    (lambda (profile generation)
 791      "Return boot parameters for PROFILE's system GENERATION."
 792      (let* ((gen-file   (generation-file-name profile generation))
 793             (param-file (string-append gen-file "/parameters")))
 794        (call-with-input-file param-file read-boot-parameters)))))
 795
 796 (define (system-generation-param-alist profile)
 797   "Return an alist of system generation parameters and procedures for
 798 PROFILE."
 799   (append (generation-param-alist profile)
 800           `((label       . ,(lambda (gen)
 801                               (boot-parameters-label
 802                                (system-generation-boot-parameters
 803                                 profile gen))))
 804             (root-device . ,(lambda (gen)
 805                               (boot-parameters-root-device
 806                                (system-generation-boot-parameters
 807                                 profile gen))))
 808             (kernel      . ,(lambda (gen)
 809                               (boot-parameters-kernel
 810                                (system-generation-boot-parameters
 811                                 profile gen)))))))
 812
 813 (define (system-generation-sexps profile params search-type search-vals)
 814   "Return an alist with information about system generations."
 815   (let ((generations (find-generations profile search-type search-vals))
 816         (->sexp (object-transformer (system-generation-param-alist profile)
 817                                     params)))
 818     (map ->sexp generations)))
 819
 820 \f
 821 ;;; Getting package/output/generation entries (alists).
 822
 823 (define (entries profile params entry-type search-type search-vals)
 824   "Return information about entries.
 825
 826 ENTRY-TYPE is a symbol defining a type of returning information.  Should
 827 be: 'package', 'output' or 'generation'.
 828
 829 SEARCH-TYPE and SEARCH-VALS define how to get the information.
 830 SEARCH-TYPE should be one of the following symbols:
 831
 832 - If ENTRY-TYPE is 'package' or 'output':
 833   'id', 'name', 'regexp', 'all-available', 'newest-available',
 834   'installed', 'obsolete', 'generation'.
 835
 836 - If ENTRY-TYPE is 'generation':
 837   'id', 'last', 'all', 'time'.
 838
 839 PARAMS is a list of parameters for receiving.  If it is an empty list,
 840 get information with all available parameters, which are:
 841
 842 - If ENTRY-TYPE is 'package':
 843   'id', 'name', 'version', 'outputs', 'license', 'synopsis',
 844   'description', 'home-url', 'inputs', 'native-inputs',
 845   'propagated-inputs', 'location', 'installed'.
 846
 847 - If ENTRY-TYPE is 'output':
 848   'id', 'package-id', 'name', 'version', 'output', 'license',
 849   'synopsis', 'description', 'home-url', 'inputs', 'native-inputs',
 850   'propagated-inputs', 'location', 'installed', 'path', 'dependencies'.
 851
 852 - If ENTRY-TYPE is 'generation':
 853   'id', 'number', 'prev-number', 'path', 'time'.
 854
 855 Returning value is a list of alists.  Each alist consists of
 856 parameter/value pairs."
 857   (case entry-type
 858     ((package output)
 859      (package/output-sexps profile params entry-type
 860                            search-type search-vals))
 861     ((generation)
 862      (generation-sexps profile params
 863                        search-type search-vals))
 864     ((system-generation)
 865      (system-generation-sexps profile params
 866                               search-type search-vals))
 867     (else (entry-type-error entry-type))))
 868
 869 \f
 870 ;;; Package actions.
 871
 872 (define* (package->manifest-entry* package #:optional output)
 873   (and package
 874        (package->manifest-entry package output)))
 875
 876 (define* (make-install-manifest-entries id #:optional output)
 877   (package->manifest-entry* (package-by-id id) output))
 878
 879 (define* (make-upgrade-manifest-entries id #:optional output)
 880   (package->manifest-entry* (newest-package-by-id id) output))
 881
 882 (define* (make-manifest-pattern id #:optional output)
 883   "Make manifest pattern from a package ID and OUTPUT."
 884   (let-values (((name version)
 885                 (id->name+version id)))
 886     (and name version
 887          (manifest-pattern
 888           (name name)
 889           (version version)
 890           (output output)))))
 891
 892 (define (convert-action-pattern pattern proc)
 893   "Convert action PATTERN into a list of objects returned by PROC.
 894 PROC is called: (PROC ID) or (PROC ID OUTPUT)."
 895   (match pattern
 896     ((id . outputs)
 897      (if (null? outputs)
 898          (let ((obj (proc id)))
 899            (if obj (list obj) '()))
 900          (filter-map (cut proc id <>)
 901                      outputs)))
 902     (_ '())))
 903
 904 (define (convert-action-patterns patterns proc)
 905   (append-map (cut convert-action-pattern <> proc)
 906               patterns))
 907
 908 (define* (process-package-actions
 909           profile #:key (install '()) (upgrade '()) (remove '())
 910           (use-substitutes? #t) dry-run?)
 911   "Perform package actions.
 912
 913 INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
 914 Each pattern should have the following form:
 915
 916   (ID . OUTPUTS)
 917
 918 ID is an object address or a full-name of a package.
 919 OUTPUTS is a list of package outputs (may be an empty list)."
 920   (format #t "The process begins ...~%")
 921   (let* ((install (append
 922                    (convert-action-patterns
 923                     install make-install-manifest-entries)
 924                    (convert-action-patterns
 925                     upgrade make-upgrade-manifest-entries)))
 926          (remove (convert-action-patterns remove make-manifest-pattern))
 927          (transaction (manifest-transaction (install install)
 928                                             (remove remove)))
 929          (manifest (profile-manifest profile))
 930          (new-manifest (manifest-perform-transaction
 931                         manifest transaction)))
 932     (unless (and (null? install) (null? remove))
 933       (with-store store
 934         (set-build-options store
 935                            #:print-build-trace #f
 936                            #:use-substitutes? use-substitutes?)
 937         (show-manifest-transaction store manifest transaction
 938                                    #:dry-run? dry-run?)
 939         (build-and-use-profile store profile new-manifest
 940                                #:use-substitutes? use-substitutes?
 941                                #:dry-run? dry-run?)))))
 942
 943 (define (delete-generations* profile generations)
 944   "Delete GENERATIONS from PROFILE.
 945 GENERATIONS is a list of generation numbers."
 946   (with-store store
 947     (delete-generations store profile generations)))
 948
 949 (define (package-location-string id-or-name)
 950   "Return a location string of a package with ID-OR-NAME."
 951   (and=> (or (package-by-id id-or-name)
 952              (match (packages-by-name id-or-name)
 953                (()              #f)
 954                ((package _ ...) package)))
 955          (compose location->string package-location)))
 956
 957 (define (package-store-path package-id)
 958   "Return a list of store directories of outputs of package PACKAGE-ID."
 959   (match (package-by-id package-id)
 960     (#f '())
 961     (package
 962       (with-store store
 963         (map (match-lambda
 964                ((_ . drv)
 965                 (derivation-output-path drv)))
 966              (derivation-outputs (package-derivation store package)))))))
 967
 968 (define (package-source-derivation->store-path derivation)
 969   "Return a store path of the package source DERIVATION."
 970   (match (derivation-outputs derivation)
 971     ;; Source derivation is always (("out" . derivation)).
 972     (((_ . output-drv))
 973      (derivation-output-path output-drv))
 974     (_ #f)))
 975
 976 (define (package-source-path package-id)
 977   "Return a store file path to a source of a package PACKAGE-ID."
 978   (and-let* ((package (package-by-id package-id))
 979              (source  (package-source package)))
 980     (with-store store
 981       (package-source-derivation->store-path
 982        (package-source-derivation store source)))))
 983
 984 (define* (package-source-build-derivation package-id #:key dry-run?
 985                                           (use-substitutes? #t))
 986   "Build source derivation of a package PACKAGE-ID."
 987   (and-let* ((package (package-by-id package-id))
 988              (source  (package-source package)))
 989     (with-store store
 990       (let* ((derivation  (package-source-derivation store source))
 991              (derivations (list derivation)))
 992         (set-build-options store
 993                            #:print-build-trace #f
 994                            #:use-substitutes? use-substitutes?)
 995         (show-what-to-build store derivations
 996                             #:use-substitutes? use-substitutes?
 997                             #:dry-run? dry-run?)
 998         (unless dry-run?
 999           (build-derivations store derivations))
1000         (format #t "The source store path: ~a~%"
1001                 (package-source-derivation->store-path derivation))))))
1002
1003 (define (package-build-log-file package-id)
1004   "Return the build log file of a package PACKAGE-ID.
1005 Return #f if the build log is not found."
1006   (and-let* ((package (package-by-id package-id)))
1007     (with-store store
1008       (let* ((derivation (package-derivation store package))
1009              (file       (derivation-file-name derivation)))
1010         (or (log-file store file)
1011             ((@@ (guix scripts build) log-url) store file))))))
1012
1013 \f
1014 ;;; Executing guix commands
1015
1016 (define (guix-command . args)
1017   "Run 'guix ARGS ...' command."
1018   (catch 'quit
1019     (lambda () (apply run-guix args))
1020     (const #t)))
1021
1022 (define (guix-command-output . args)
1023   "Return 2 strings with 'guix ARGS ...' output and error output."
1024   (output+error
1025    (lambda ()
1026      (parameterize ((guix-warning-port (current-error-port)))
1027        (apply guix-command args)))))
1028
1029 (define (help-string . commands)
1030   "Return string with 'guix COMMANDS ... --help' output."
1031   (apply guix-command-output `(,@commands "--help")))
1032
1033 (define (pipe-guix-output guix-args command-args)
1034   "Run 'guix GUIX-ARGS ...' command and pipe its output to a shell command
1035 defined by COMMAND-ARGS.
1036 Return #t if the shell command was executed successfully."
1037   (let ((pipe (apply open-pipe* OPEN_WRITE command-args)))
1038     (with-output-to-port pipe
1039       (lambda () (apply guix-command guix-args)))
1040     (zero? (status:exit-val (close-pipe pipe)))))
1041
1042 \f
1043 ;;; Lists of packages, lint checkers, etc.
1044
1045 (define (graph-type-names)
1046   "Return a list of names of available graph node types."
1047   (map (@ (guix graph) node-type-name)
1048        (@ (guix scripts graph) %node-types)))
1049
1050 (define (refresh-updater-names)
1051   "Return a list of names of available refresh updater types."
1052   (map (@ (guix upstream) upstream-updater-name)
1053        (@ (guix scripts refresh) %updaters)))
1054
1055 (define (lint-checker-names)
1056   "Return a list of names of available lint checkers."
1057   (map (lambda (checker)
1058          (symbol->string ((@ (guix scripts lint) lint-checker-name)
1059                           checker)))
1060        (@ (guix scripts lint) %checkers)))
1061
1062 (define (package-names)
1063   "Return a list of names of available packages."
1064   (delete-duplicates
1065    (fold-packages (lambda (pkg res)
1066                     (cons (package-name pkg) res))
1067                   '())))
1068
1069 ;; See the comment to 'guix-package-names' function in "guix-popup.el".
1070 (define (package-names-lists)
1071   (map list (package-names)))
1072
1073 \f
1074 ;;; Licenses
1075
1076 (define %licenses
1077   (delay
1078     (filter license?
1079             (module-map (lambda (_ var)
1080                           (variable-ref var))
1081                         (resolve-interface '(guix licenses))))))
1082
1083 (define (licenses)
1084   (force %licenses))
1085
1086 (define (license-names)
1087   "Return a list of names of available licenses."
1088   (map license-name (licenses)))
1089
1090 (define lookup-license
1091   (memoize
1092    (lambda (name)
1093      "Return a license by its name."
1094      (find (lambda (l)
1095              (string=? name (license-name l)))
1096            (licenses)))))
1097
1098 (define (lookup-license-uri name)
1099   "Return a license URI by its name."
1100   (and=> (lookup-license name)
1101          license-uri))
1102
1103 (define %license-param-alist
1104   `((id      . ,license-name)
1105     (name    . ,license-name)
1106     (url     . ,license-uri)
1107     (comment . ,license-comment)))
1108
1109 (define license->sexp
1110   (object-transformer %license-param-alist))
1111
1112 (define (find-licenses search-type . search-values)
1113   "Return a list of licenses depending on SEARCH-TYPE and SEARCH-VALUES."
1114   (case search-type
1115     ((id name)
1116      (let ((names search-values))
1117        (filter-map lookup-license names)))
1118     ((all)
1119      (licenses))))
1120
1121 (define (license-entries search-type . search-values)
1122   (map license->sexp
1123        (apply find-licenses search-type search-values)))
1124
1125 \f
1126 ;;; Package locations
1127
1128 (define-values (packages-by-location-file
1129                 package-location-files)
1130   (let* ((table (delay (fold-packages
1131                         (lambda (package table)
1132                           (let ((file (location-file
1133                                        (package-location package))))
1134                             (vhash-cons file package table)))
1135                         vlist-null)))
1136          (files (delay (vhash-fold
1137                         (lambda (file _ result)
1138                           (if (member file result)
1139                               result
1140                               (cons file result)))
1141                         '()
1142                         (force table)))))
1143     (values
1144      (lambda (file)
1145        "Return the (possibly empty) list of packages defined in location FILE."
1146        (vhash-fold* cons '() file (force table)))
1147      (lambda ()
1148        "Return the list of file names of all package locations."
1149        (force files)))))
1150
1151 (define %package-location-param-alist
1152   `((id       . ,identity)
1153     (location . ,identity)
1154     (number-of-packages . ,(lambda (location)
1155                              (length (packages-by-location-file location))))))
1156
1157 (define package-location->sexp
1158   (object-transformer %package-location-param-alist))
1159
1160 (define (package-location-entries)
1161   (map package-location->sexp (package-location-files)))