gnu/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   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 (define-module (gnu packages)
  20   #:use-module (guix packages)
  21   #:use-module (guix utils)
  22   #:use-module (ice-9 ftw)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (srfi srfi-39)
  26   #:export (search-patch
  27             search-bootstrap-binary
  28             %patch-directory
  29             %bootstrap-binaries-path
  30             fold-packages
  31             find-packages-by-name))
  32
  33 ;;; Commentary:
  34 ;;;
  35 ;;; General utilities for the software distribution---i.e., the modules under
  36 ;;; (gnu packages ...).
  37 ;;;
  38 ;;; Code:
  39
  40 (define _ (cut gettext <> "guix"))
  41
  42 ;; By default, we store patches and bootstrap binaries alongside Guile
  43 ;; modules.  This is so that these extra files can be found without
  44 ;; requiring a special setup, such as a specific installation directory
  45 ;; and an extra environment variable.  One advantage of this setup is
  46 ;; that everything just works in an auto-compilation setting.
  47
  48 (define %patch-path
  49   (make-parameter
  50    (map (cut string-append <>  "/gnu/packages/patches")
  51         %load-path)))
  52
  53 (define %bootstrap-binaries-path
  54   (make-parameter
  55    (map (cut string-append <> "/gnu/packages/bootstrap")
  56         %load-path)))
  57
  58 (define (search-patch file-name)
  59   "Search the patch FILE-NAME."
  60   (search-path (%patch-path) file-name))
  61
  62 (define (search-bootstrap-binary file-name system)
  63   "Search the bootstrap binary FILE-NAME for SYSTEM."
  64   (search-path (%bootstrap-binaries-path)
  65                (string-append system "/" file-name)))
  66
  67 (define %distro-module-directory
  68   ;; Absolute path of the (gnu packages ...) module root.
  69   (string-append (dirname (search-path %load-path "gnu/packages.scm"))
  70                  "/packages"))
  71
  72 (define (package-files)
  73   "Return the list of files that implement distro modules."
  74   (define prefix-len
  75     (string-length
  76      (dirname (dirname (search-path %load-path "gnu/packages.scm")))))
  77
  78   (file-system-fold (const #t)                    ; enter?
  79                     (lambda (path stat result)    ; leaf
  80                       (if (string-suffix? ".scm" path)
  81                           (cons (substring path prefix-len) result)
  82                           result))
  83                     (lambda (path stat result)    ; down
  84                       result)
  85                     (lambda (path stat result)    ; up
  86                       result)
  87                     (const #f)                    ; skip
  88                     (lambda (path stat errno result)
  89                       (format (current-error-port)
  90                               (_ "warning: cannot access `~a': ~a~%")
  91                               path (strerror errno))
  92                       result)
  93                     '()
  94                     %distro-module-directory
  95                     stat))
  96
  97 (define (package-modules)
  98   "Return the list of modules that provide packages for the distribution."
  99   (define not-slash
 100     (char-set-complement (char-set #\/)))
 101
 102   (filter-map (lambda (path)
 103                 (let ((name (map string->symbol
 104                                  (string-tokenize (string-drop-right path 4)
 105                                                   not-slash))))
 106                   (false-if-exception (resolve-interface name))))
 107               (package-files)))
 108
 109 (define (fold-packages proc init)
 110   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 111 the initial value of RESULT."
 112   (fold (lambda (module result)
 113           (fold (lambda (var result)
 114                   (if (package? var)
 115                       (proc var result)
 116                       result))
 117                 result
 118                 (module-map (lambda (sym var)
 119                               (false-if-exception (variable-ref var)))
 120                             module)))
 121         init
 122         (package-modules)))
 123
 124 (define* (find-packages-by-name name #:optional version)
 125   "Return the list of packages with the given NAME.  If VERSION is not #f,
 126 then only return packages whose version is equal to VERSION."
 127   (define right-package?
 128     (if version
 129         (lambda (p)
 130           (and (string=? (package-name p) name)
 131                (string=? (package-version p) version)))
 132         (lambda (p)
 133           (string=? (package-name p) name))))
 134
 135   (fold-packages (lambda (package result)
 136                    (if (right-package? package)
 137                        (cons package result)
 138                        result))
 139                  '()))