distro.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; 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 ;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (distro)
  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 ;;; (distro ...).
  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 <>  "/distro/packages/patches")
  51         %load-path)))
  52
  53 (define %bootstrap-binaries-path
  54   (make-parameter
  55    (map (cut string-append <> "/distro/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 (distro ...) module root.
  69   (string-append (dirname (search-path %load-path "distro.scm"))
  70                  "/distro/packages"))
  71
  72 (define (package-files)
  73   "Return the list of files that implement distro modules."
  74   (define prefix-len
  75     (string-length (dirname (search-path %load-path "distro.scm"))))
  76
  77   (file-system-fold (const #t)                    ; enter?
  78                     (lambda (path stat result)    ; leaf
  79                       (if (string-suffix? ".scm" path)
  80                           (cons (substring path prefix-len) result)
  81                           result))
  82                     (lambda (path stat result)    ; down
  83                       result)
  84                     (lambda (path stat result)    ; up
  85                       result)
  86                     (const #f)                    ; skip
  87                     (lambda (path stat errno result)
  88                       (format (current-error-port)
  89                               (_ "warning: cannot access `~a': ~a~%")
  90                               path (strerror errno))
  91                       result)
  92                     '()
  93                     %distro-module-directory
  94                     stat))
  95
  96 (define (package-modules)
  97   "Return the list of modules that provide packages for the distribution."
  98   (define not-slash
  99     (char-set-complement (char-set #\/)))
 100
 101   (filter-map (lambda (path)
 102                 (let ((name (map string->symbol
 103                                  (string-tokenize (string-drop-right path 4)
 104                                                   not-slash))))
 105                   (false-if-exception (resolve-interface name))))
 106               (package-files)))
 107
 108 (define (fold-packages proc init)
 109   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 110 the initial value of RESULT."
 111   (fold (lambda (module result)
 112           (fold (lambda (var result)
 113                   (if (package? var)
 114                       (proc var result)
 115                       result))
 116                 result
 117                 (module-map (lambda (sym var)
 118                               (false-if-exception (variable-ref var)))
 119                             module)))
 120         init
 121         (package-modules)))
 122
 123 (define* (find-packages-by-name name #:optional version)
 124   "Return the list of packages with the given NAME.  If VERSION is not #f,
 125 then only return packages whose version is equal to VERSION."
 126   (define right-package?
 127     (if version
 128         (lambda (p)
 129           (and (string=? (package-name p) name)
 130                (string=? (package-version p) version)))
 131         (lambda (p)
 132           (string=? (package-name p) name))))
 133
 134   (fold-packages (lambda (package result)
 135                    (if (right-package? package)
 136                        (cons package result)
 137                        result))
 138                  '()))