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