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 ;; By default, we store patches and bootstrap binaries alongside Guile
  54 ;; modules.  This is so that these extra files can be found without
  55 ;; requiring a special setup, such as a specific installation directory
  56 ;; and an extra environment variable.  One advantage of this setup is
  57 ;; that everything just works in an auto-compilation setting.
  58
  59 (define %patch-path
  60   (make-parameter
  61    (map (cut string-append <> "/gnu/packages/patches")
  62         %load-path)))
  63
  64 (define %bootstrap-binaries-path
  65   (make-parameter
  66    (map (cut string-append <> "/gnu/packages/bootstrap")
  67         %load-path)))
  68
  69 (define (search-patch file-name)
  70   "Search the patch FILE-NAME."
  71   (search-path (%patch-path) file-name))
  72
  73 (define (search-bootstrap-binary file-name system)
  74   "Search the bootstrap binary FILE-NAME for SYSTEM."
  75   (search-path (%bootstrap-binaries-path)
  76                (string-append system "/" file-name)))
  77
  78 (define %distro-module-directory
  79   ;; Absolute path of the (gnu packages ...) module root.
  80   (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  81                  "/packages"))
  82
  83 (define (package-files)
  84   "Return the list of files that implement distro modules."
  85   (define prefix-len
  86     (string-length
  87      (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  88
  89   (file-system-fold (const #t)                    ; enter?
  90                     (lambda (path stat result)    ; leaf
  91                       (if (string-suffix? ".scm" path)
  92                           (cons (substring path prefix-len) result)
  93                           result))
  94                     (lambda (path stat result)    ; down
  95                       result)
  96                     (lambda (path stat result)    ; up
  97                       result)
  98                     (const #f)                    ; skip
  99                     (lambda (path stat errno result)
 100                       (warning (_ "cannot access `~a': ~a~%")
 101                                path (strerror errno))
 102                       result)
 103                     '()
 104                     %distro-module-directory
 105                     stat))
 106
 107 (define (package-modules)
 108   "Return the list of modules that provide packages for the distribution."
 109   (define not-slash
 110     (char-set-complement (char-set #\/)))
 111
 112   (filter-map (lambda (path)
 113                 (let ((name (map string->symbol
 114                                  (string-tokenize (string-drop-right path 4)
 115                                                   not-slash))))
 116                   (false-if-exception (resolve-interface name))))
 117               (package-files)))
 118
 119 (define (fold-packages proc init)
 120   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 121 the initial value of RESULT.  It is guaranteed to never traverse the
 122 same package twice."
 123   (identity   ; discard second return value
 124    (fold2 (lambda (module result seen)
 125             (fold2 (lambda (var result seen)
 126                      (if (and (package? var)
 127                               (not (vhash-assq var seen)))
 128                          (values (proc var result)
 129                                  (vhash-consq var #t seen))
 130                          (values result seen)))
 131                    result
 132                    seen
 133                    (module-map (lambda (sym var)
 134                                  (false-if-exception (variable-ref var)))
 135                                module)))
 136           init
 137           vlist-null
 138           (package-modules))))
 139
 140 (define* (find-packages-by-name name #:optional version)
 141   "Return the list of packages with the given NAME.  If VERSION is not #f,
 142 then only return packages whose version is equal to VERSION."
 143   (define right-package?
 144     (if version
 145         (lambda (p)
 146           (and (string=? (package-name p) name)
 147                (string=? (package-version p) version)))
 148         (lambda (p)
 149           (string=? (package-name p) name))))
 150
 151   (fold-packages (lambda (package result)
 152                    (if (right-package? package)
 153                        (cons package result)
 154                        result))
 155                  '()))
 156
 157 (define find-newest-available-packages
 158   (memoize
 159    (lambda ()
 160      "Return a vhash keyed by package names, and with
 161 associated values of the form
 162
 163   (newest-version newest-package ...)
 164
 165 where the preferred package is listed first."
 166
 167      ;; FIXME: Currently, the preferred package is whichever one
 168      ;; was found last by 'fold-packages'.  Find a better solution.
 169      (fold-packages (lambda (p r)
 170                       (let ((name    (package-name p))
 171                             (version (package-version p)))
 172                         (match (vhash-assoc name r)
 173                           ((_ newest-so-far . pkgs)
 174                            (case (version-compare version newest-so-far)
 175                              ((>) (vhash-cons name `(,version ,p) r))
 176                              ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 177                              ((<) r)))
 178                           (#f (vhash-cons name `(,version ,p) r)))))
 179                     vlist-null))))
 180
 181 (define (find-best-packages-by-name name version)
 182   "If version is #f, return the list of packages named NAME with the highest
 183 version numbers; otherwise, return the list of packages named NAME and at
 184 VERSION."
 185   (if version
 186       (find-packages-by-name name version)
 187       (match (vhash-assoc name (find-newest-available-packages))
 188         ((_ version pkgs ...) pkgs)
 189         (#f '()))))
 190
 191 \f
 192 (define* (vhash-refq vhash key #:optional (dflt #f))
 193   "Look up KEY in the vhash VHASH, and return the value (if any) associated
 194 with it.  If KEY is not found, return DFLT (or `#f' if no DFLT argument is
 195 supplied).  Uses `eq?' for equality testing."
 196   (or (and=> (vhash-assq key vhash) cdr)
 197       dflt))
 198
 199 (define package-dependencies
 200   (memoize
 201    (lambda ()
 202      "Return a vhash keyed by package, and with associated values that are a
 203 list of packages that depend on that package."
 204      (fold-packages
 205       (lambda (package dag)
 206         (fold
 207          (lambda (in d)
 208            ;; Insert a graph edge from each of package's inputs to package.
 209            (vhash-consq in
 210                         (cons package (vhash-refq d in '()))
 211                         (vhash-delq in d)))
 212          dag
 213          (match (package-direct-inputs package)
 214            (((labels packages . _) ...)
 215             packages) )))
 216       vlist-null))))
 217
 218 (define (package-direct-dependents packages)
 219   "Return a list of packages from the distribution that directly depend on the
 220 packages in PACKAGES."
 221   (delete-duplicates
 222    (concatenate
 223     (map (lambda (p)
 224            (vhash-refq (package-dependencies) p '()))
 225          packages))))
 226
 227 (define (package-transitive-dependents packages)
 228   "Return the transitive dependent packages of the distribution packages in
 229 PACKAGES---i.e. the dependents of those packages, plus their dependents,
 230 recursively."
 231   (let ((dependency-dag (package-dependencies)))
 232     (fold-tree
 233      cons '()
 234      (lambda (node) (vhash-refq dependency-dag node))
 235      ;; Start with the dependents to avoid including PACKAGES in the result.
 236      (package-direct-dependents packages))))
 237
 238 (define (package-covering-dependents packages)
 239   "Return a minimal list of packages from the distribution whose dependencies
 240 include all of PACKAGES and all packages that depend on PACKAGES."
 241   (let ((dependency-dag (package-dependencies)))
 242     (fold-tree-leaves
 243      cons '()
 244      (lambda (node) (vhash-refq dependency-dag node))
 245      ;; Start with the dependents to avoid including PACKAGES in the result.
 246      (package-direct-dependents packages))))