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