gnu/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu packages)
  22   #:use-module (guix packages)
  23   #:use-module (guix ui)
  24   #:use-module (guix utils)
  25   #:use-module (ice-9 ftw)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (srfi srfi-39)
  31   #:export (search-patch
  32             search-bootstrap-binary
  33             %patch-directory
  34             %bootstrap-binaries-path
  35
  36             fold-packages
  37
  38             find-packages-by-name
  39             find-best-packages-by-name
  40             find-newest-available-packages
  41
  42             package-direct-dependents
  43             package-transitive-dependents
  44             package-covering-dependents))
  45
  46 ;;; Commentary:
  47 ;;;
  48 ;;; General utilities for the software distribution---i.e., the modules under
  49 ;;; (gnu packages ...).
  50 ;;;
  51 ;;; Code:
  52
  53 (define _ (cut gettext <> "guix"))
  54
  55 ;; By default, we store patches and bootstrap binaries alongside Guile
  56 ;; modules.  This is so that these extra files can be found without
  57 ;; requiring a special setup, such as a specific installation directory
  58 ;; and an extra environment variable.  One advantage of this setup is
  59 ;; that everything just works in an auto-compilation setting.
  60
  61 (define %patch-path
  62   (make-parameter
  63    (map (cut string-append <>  "/gnu/packages/patches")
  64         %load-path)))
  65
  66 (define %bootstrap-binaries-path
  67   (make-parameter
  68    (map (cut string-append <> "/gnu/packages/bootstrap")
  69         %load-path)))
  70
  71 (define (search-patch file-name)
  72   "Search the patch FILE-NAME."
  73   (search-path (%patch-path) file-name))
  74
  75 (define (search-bootstrap-binary file-name system)
  76   "Search the bootstrap binary FILE-NAME for SYSTEM."
  77   (search-path (%bootstrap-binaries-path)
  78                (string-append system "/" file-name)))
  79
  80 (define %distro-module-directory
  81   ;; Absolute path of the (gnu packages ...) module root.
  82   (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  83                  "/packages"))
  84
  85 (define (package-files)
  86   "Return the list of files that implement distro modules."
  87   (define prefix-len
  88     (string-length
  89      (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  90
  91   (file-system-fold (const #t)                    ; enter?
  92                     (lambda (path stat result)    ; leaf
  93                       (if (string-suffix? ".scm" path)
  94                           (cons (substring path prefix-len) result)
  95                           result))
  96                     (lambda (path stat result)    ; down
  97                       result)
  98                     (lambda (path stat result)    ; up
  99                       result)
 100                     (const #f)                    ; skip
 101                     (lambda (path stat errno result)
 102                       (warning (_ "cannot access `~a': ~a~%")
 103                                path (strerror errno))
 104                       result)
 105                     '()
 106                     %distro-module-directory
 107                     stat))
 108
 109 (define (package-modules)
 110   "Return the list of modules that provide packages for the distribution."
 111   (define not-slash
 112     (char-set-complement (char-set #\/)))
 113
 114   (filter-map (lambda (path)
 115                 (let ((name (map string->symbol
 116                                  (string-tokenize (string-drop-right path 4)
 117                                                   not-slash))))
 118                   (false-if-exception (resolve-interface name))))
 119               (package-files)))
 120
 121 (define (fold-packages proc init)
 122   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 123 the initial value of RESULT.  It is guaranteed to never traverse the
 124 same package twice."
 125   (identity   ; discard second return value
 126    (fold2 (lambda (module result seen)
 127             (fold2 (lambda (var result seen)
 128                      (if (and (package? var)
 129                               (not (vhash-assq var seen)))
 130                          (values (proc var result)
 131                                  (vhash-consq var #t seen))
 132                          (values result seen)))
 133                    result
 134                    seen
 135                    (module-map (lambda (sym var)
 136                                  (false-if-exception (variable-ref var)))
 137                                module)))
 138           init
 139           vlist-null
 140           (package-modules))))
 141
 142 (define* (find-packages-by-name name #:optional version)
 143   "Return the list of packages with the given NAME.  If VERSION is not #f,
 144 then only return packages whose version is equal to VERSION."
 145   (define right-package?
 146     (if version
 147         (lambda (p)
 148           (and (string=? (package-name p) name)
 149                (string=? (package-version p) version)))
 150         (lambda (p)
 151           (string=? (package-name p) name))))
 152
 153   (fold-packages (lambda (package result)
 154                    (if (right-package? package)
 155                        (cons package result)
 156                        result))
 157                  '()))
 158
 159 (define find-newest-available-packages
 160   (memoize
 161    (lambda ()
 162      "Return a vhash keyed by package names, and with
 163 associated values of the form
 164
 165   (newest-version newest-package ...)
 166
 167 where the preferred package is listed first."
 168
 169      ;; FIXME: Currently, the preferred package is whichever one
 170      ;; was found last by 'fold-packages'.  Find a better solution.
 171      (fold-packages (lambda (p r)
 172                       (let ((name    (package-name p))
 173                             (version (package-version p)))
 174                         (match (vhash-assoc name r)
 175                           ((_ newest-so-far . pkgs)
 176                            (case (version-compare version newest-so-far)
 177                              ((>) (vhash-cons name `(,version ,p) r))
 178                              ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 179                              ((<) r)))
 180                           (#f (vhash-cons name `(,version ,p) r)))))
 181                     vlist-null))))
 182
 183 (define (find-best-packages-by-name name version)
 184   "If version is #f, return the list of packages named NAME with the highest
 185 version numbers; otherwise, return the list of packages named NAME and at
 186 VERSION."
 187   (if version
 188       (find-packages-by-name name version)
 189       (match (vhash-assoc name (find-newest-available-packages))
 190         ((_ version pkgs ...) pkgs)
 191         (#f '()))))
 192
 193 \f
 194 (define* (vhash-refq vhash key #:optional (dflt #f))
 195   "Look up KEY in the vhash VHASH, and return the value (if any) associated
 196 with it.  If KEY is not found, return DFLT (or `#f' if no DFLT argument is
 197 supplied).  Uses `eq?' for equality testing."
 198   (or (and=> (vhash-assq key vhash) cdr)
 199       dflt))
 200
 201 (define package-dependencies
 202   (memoize
 203    (lambda ()
 204      "Return a vhash keyed by package, and with associated values that are a
 205 list of packages that depend on that package."
 206      (fold-packages
 207       (lambda (package dag)
 208         (fold
 209          (lambda (in d)
 210            ;; Insert a graph edge from each of package's inputs to package.
 211            (vhash-consq in
 212                         (cons package (vhash-refq d in '()))
 213                         (vhash-delq in d)))
 214          dag
 215          (match (package-direct-inputs package)
 216            (((labels packages . _) ...)
 217             packages) )))
 218       vlist-null))))
 219
 220 (define (package-direct-dependents packages)
 221   "Return a list of packages from the distribution that directly depend on the
 222 packages in PACKAGES."
 223   (delete-duplicates
 224    (concatenate
 225     (map (lambda (p)
 226            (vhash-refq (package-dependencies) p '()))
 227          packages))))
 228
 229 (define (package-transitive-dependents packages)
 230   "Return the transitive dependent packages of the distribution packages in
 231 PACKAGES---i.e. the dependents of those packages, plus their dependents,
 232 recursively."
 233   (let ((dependency-dag (package-dependencies)))
 234     (fold-tree
 235      cons '()
 236      (lambda (node) (vhash-refq dependency-dag node))
 237      ;; Start with the dependents to avoid including PACKAGES in the result.
 238      (package-direct-dependents packages))))
 239
 240 (define (package-covering-dependents packages)
 241   "Return a minimal list of packages from the distribution whose dependencies
 242 include all of PACKAGES and all packages that depend on PACKAGES."
 243   (let ((dependency-dag (package-dependencies)))
 244     (fold-tree-leaves
 245      cons '()
 246      (lambda (node) (vhash-refq dependency-dag node))
 247      ;; Start with the dependents to avoid including PACKAGES in the result.
 248      (package-direct-dependents packages))))