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 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu packages)
  21   #:use-module (guix packages)
  22   #:use-module (guix ui)
  23   #:use-module (guix utils)
  24   #:use-module (ice-9 ftw)
  25   #:use-module (ice-9 vlist)
  26   #:use-module (ice-9 match)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (srfi srfi-39)
  30   #:export (search-patch
  31             search-bootstrap-binary
  32             %patch-directory
  33             %bootstrap-binaries-path
  34             fold-packages
  35             find-packages-by-name
  36             find-best-packages-by-name
  37             find-newest-available-packages))
  38
  39 ;;; Commentary:
  40 ;;;
  41 ;;; General utilities for the software distribution---i.e., the modules under
  42 ;;; (gnu packages ...).
  43 ;;;
  44 ;;; Code:
  45
  46 (define _ (cut gettext <> "guix"))
  47
  48 ;; By default, we store patches and bootstrap binaries alongside Guile
  49 ;; modules.  This is so that these extra files can be found without
  50 ;; requiring a special setup, such as a specific installation directory
  51 ;; and an extra environment variable.  One advantage of this setup is
  52 ;; that everything just works in an auto-compilation setting.
  53
  54 (define %patch-path
  55   (make-parameter
  56    (map (cut string-append <>  "/gnu/packages/patches")
  57         %load-path)))
  58
  59 (define %bootstrap-binaries-path
  60   (make-parameter
  61    (map (cut string-append <> "/gnu/packages/bootstrap")
  62         %load-path)))
  63
  64 (define (search-patch file-name)
  65   "Search the patch FILE-NAME."
  66   (search-path (%patch-path) file-name))
  67
  68 (define (search-bootstrap-binary file-name system)
  69   "Search the bootstrap binary FILE-NAME for SYSTEM."
  70   (search-path (%bootstrap-binaries-path)
  71                (string-append system "/" file-name)))
  72
  73 (define %distro-module-directory
  74   ;; Absolute path of the (gnu packages ...) module root.
  75   (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  76                  "/packages"))
  77
  78 (define (package-files)
  79   "Return the list of files that implement distro modules."
  80   (define prefix-len
  81     (string-length
  82      (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  83
  84   (file-system-fold (const #t)                    ; enter?
  85                     (lambda (path stat result)    ; leaf
  86                       (if (string-suffix? ".scm" path)
  87                           (cons (substring path prefix-len) result)
  88                           result))
  89                     (lambda (path stat result)    ; down
  90                       result)
  91                     (lambda (path stat result)    ; up
  92                       result)
  93                     (const #f)                    ; skip
  94                     (lambda (path stat errno result)
  95                       (warning (_ "cannot access `~a': ~a~%")
  96                                path (strerror errno))
  97                       result)
  98                     '()
  99                     %distro-module-directory
 100                     stat))
 101
 102 (define (package-modules)
 103   "Return the list of modules that provide packages for the distribution."
 104   (define not-slash
 105     (char-set-complement (char-set #\/)))
 106
 107   (filter-map (lambda (path)
 108                 (let ((name (map string->symbol
 109                                  (string-tokenize (string-drop-right path 4)
 110                                                   not-slash))))
 111                   (false-if-exception (resolve-interface name))))
 112               (package-files)))
 113
 114 (define (fold-packages proc init)
 115   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 116 the initial value of RESULT.  It is guaranteed to never traverse the
 117 same package twice."
 118   (identity   ; discard second return value
 119    (fold2 (lambda (module result seen)
 120             (fold2 (lambda (var result seen)
 121                      (if (and (package? var)
 122                               (not (vhash-assq var seen)))
 123                          (values (proc var result)
 124                                  (vhash-consq var #t seen))
 125                          (values result seen)))
 126                    result
 127                    seen
 128                    (module-map (lambda (sym var)
 129                                  (false-if-exception (variable-ref var)))
 130                                module)))
 131           init
 132           vlist-null
 133           (package-modules))))
 134
 135 (define* (find-packages-by-name name #:optional version)
 136   "Return the list of packages with the given NAME.  If VERSION is not #f,
 137 then only return packages whose version is equal to VERSION."
 138   (define right-package?
 139     (if version
 140         (lambda (p)
 141           (and (string=? (package-name p) name)
 142                (string=? (package-version p) version)))
 143         (lambda (p)
 144           (string=? (package-name p) name))))
 145
 146   (fold-packages (lambda (package result)
 147                    (if (right-package? package)
 148                        (cons package result)
 149                        result))
 150                  '()))
 151
 152 (define find-newest-available-packages
 153   (memoize
 154    (lambda ()
 155      "Return a vhash keyed by package names, and with
 156 associated values of the form
 157
 158   (newest-version newest-package ...)
 159
 160 where the preferred package is listed first."
 161
 162      ;; FIXME: Currently, the preferred package is whichever one
 163      ;; was found last by 'fold-packages'.  Find a better solution.
 164      (fold-packages (lambda (p r)
 165                       (let ((name    (package-name p))
 166                             (version (package-version p)))
 167                         (match (vhash-assoc name r)
 168                           ((_ newest-so-far . pkgs)
 169                            (case (version-compare version newest-so-far)
 170                              ((>) (vhash-cons name `(,version ,p) r))
 171                              ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 172                              ((<) r)))
 173                           (#f (vhash-cons name `(,version ,p) r)))))
 174                     vlist-null))))
 175
 176 (define (find-best-packages-by-name name version)
 177   "If version is #f, return the list of packages named NAME with the highest
 178 version numbers; otherwise, return the list of packages named NAME and at
 179 VERSION."
 180   (if version
 181       (find-packages-by-name name version)
 182       (match (vhash-assoc name (find-newest-available-packages))
 183         ((_ version pkgs ...) pkgs)
 184         (#f '()))))