guix/build-system/gnu.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012 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 (guix build-system gnu)
  20   #:use-module (guix store)
  21   #:use-module (guix utils)
  22   #:use-module (guix derivations)
  23   #:use-module (guix build-system)
  24   #:use-module (guix packages)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-39)
  27   #:use-module (ice-9 match)
  28   #:export (gnu-build
  29             gnu-build-system
  30             package-with-explicit-inputs
  31             package-with-extra-configure-variable
  32             static-libgcc-package))
  33
  34 ;; Commentary:
  35 ;;
  36 ;; Standard build procedure for packages using the GNU Build System or
  37 ;; something compatible ("./configure && make && make install").
  38 ;;
  39 ;; Code:
  40
  41 (define* (package-with-explicit-inputs p boot-inputs
  42                                        #:optional
  43                                        (loc (current-source-location))
  44                                        #:key guile)
  45   "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take
  46 BOOT-INPUTS as explicit inputs instead of the implicit default, and
  47 return it.  Use GUILE to run the builder, or the distro's final Guile
  48 when GUILE is #f."
  49   (define rewritten-input
  50     (match-lambda
  51      ((name (? package? p) sub-drv ...)
  52       (cons* name
  53              (package-with-explicit-inputs p boot-inputs #:guile guile)
  54              sub-drv))
  55      (x x)))
  56
  57   (define boot-input-names
  58     (map car boot-inputs))
  59
  60   (define (filtered-inputs inputs)
  61     (fold alist-delete inputs boot-input-names))
  62
  63   (package (inherit p)
  64     (location (if (pair? loc) (source-properties->location loc) loc))
  65     (arguments
  66      (let ((args (package-arguments p)))
  67        (if (procedure? args)
  68            (lambda (system)
  69              `(#:guile ,guile
  70                #:implicit-inputs? #f ,@(args system)))
  71            `(#:guile ,guile
  72              #:implicit-inputs? #f ,@args))))
  73     (native-inputs (map rewritten-input
  74                         (filtered-inputs (package-native-inputs p))))
  75     (propagated-inputs (map rewritten-input
  76                             (filtered-inputs
  77                              (package-propagated-inputs p))))
  78     (inputs `(,@boot-inputs
  79               ,@(map rewritten-input
  80                      (filtered-inputs (package-inputs p)))))))
  81
  82 (define (package-with-extra-configure-variable p variable value)
  83   "Return a version of P with VARIABLE=VALUE specified as an extra
  84 `configure' flag.  An example is LDFLAGS=-static.  If P already has
  85 configure flags for VARIABLE, the associated value is augmented."
  86   (let loop ((p p))
  87     (define (rewritten-inputs inputs)
  88       (map (match-lambda
  89             ((name (? package? p) sub ...)
  90              `(,name ,(loop p) ,@sub))
  91             (input input))
  92            inputs))
  93
  94     (package (inherit p)
  95       (arguments
  96        (lambda (system)
  97          (let ((args (match (package-arguments p)
  98                        ((? procedure? proc)
  99                         (proc system))
 100                        (x x))))
 101           (substitute-keyword-arguments args
 102             ((#:configure-flags flags)
 103              (let* ((var= (string-append variable "="))
 104                     (len  (string-length var=)))
 105                `(cons ,(string-append var= value)
 106                       (map (lambda (flag)
 107                              (if (string-prefix? ,var= flag)
 108                                  (string-append
 109                                   ,(string-append var= value " ")
 110                                   (substring flag ,len))
 111                                  flag))
 112                            ,flags))))))))
 113       (inputs (rewritten-inputs (package-inputs p)))
 114       (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
 115
 116 (define (static-libgcc-package p)
 117   "A version of P linked with `-static-gcc'."
 118   (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc"))
 119
 120 \f
 121 (define %store
 122   ;; Store passed to STANDARD-INPUTS.
 123   (make-parameter #f))
 124
 125 (define standard-inputs
 126   (memoize
 127    (lambda (system)
 128      "Return the list of implicit standard inputs used with the GNU Build
 129 System: GCC, GNU Make, Bash, Coreutils, etc."
 130      (map (match-lambda
 131            ((name pkg sub-drv ...)
 132             (cons* name (package-derivation (%store) pkg system) sub-drv))
 133            ((name (? derivation-path? path) sub-drv ...)
 134             (cons* name path sub-drv))
 135            (z
 136             (error "invalid standard input" z)))
 137
 138           ;; Resolve (distro packages base) lazily to hide circular dependency.
 139           (let* ((distro (resolve-module '(distro packages base)))
 140                  (inputs (module-ref distro '%final-inputs)))
 141             (append inputs
 142                     (append-map (match-lambda
 143                                  ((name package _ ...)
 144                                   (package-transitive-propagated-inputs package)))
 145                                 inputs)))))))
 146
 147 (define* (gnu-build store name source inputs
 148                     #:key (guile #f)
 149                     (outputs '("out")) (configure-flags ''())
 150                     (make-flags ''())
 151                     (patches ''()) (patch-flags ''("--batch" "-p1"))
 152                     (out-of-source? #f)
 153                     (path-exclusions ''())
 154                     (tests? #t)
 155                     (parallel-build? #t) (parallel-tests? #t)
 156                     (patch-shebangs? #t)
 157                     (strip-binaries? #t)
 158                     (strip-flags ''("--strip-debug"))
 159                     (strip-directories ''("lib" "lib64" "libexec"
 160                                           "bin" "sbin"))
 161                     (phases '%standard-phases)
 162                     (system (%current-system))
 163                     (implicit-inputs? #t)    ; useful when bootstrapping
 164                     (imported-modules '((guix build gnu-build-system)
 165                                         (guix build utils)))
 166                     (modules '((guix build gnu-build-system)
 167                                (guix build utils))))
 168   "Return a derivation called NAME that builds from tarball SOURCE, with
 169 input derivation INPUTS, using the usual procedure of the GNU Build
 170 System.  The builder is run with GUILE, or with the distro's final Guile
 171 package if GUILE is #f or omitted.
 172
 173 The builder is run in a context where MODULES are used; IMPORTED-MODULES
 174 specifies modules not provided by Guile itself that must be imported in
 175 the builder's environment, from the host.  Note that we distinguish
 176 between both, because for Guile's own modules like (ice-9 foo), we want
 177 to use GUILE's own version of it, rather than import the user's one,
 178 which could lead to gratuitous input divergence."
 179   (define builder
 180     `(begin
 181        (use-modules ,@modules)
 182        (gnu-build #:source ,(if (derivation-path? source)
 183                                 (derivation-path->output-path source)
 184                                 source)
 185                   #:system ,system
 186                   #:outputs %outputs
 187                   #:inputs %build-inputs
 188                   #:patches ,patches
 189                   #:patch-flags ,patch-flags
 190                   #:phases ,phases
 191                   #:configure-flags ,configure-flags
 192                   #:make-flags ,make-flags
 193                   #:out-of-source? ,out-of-source?
 194                   #:path-exclusions ,path-exclusions
 195                   #:tests? ,tests?
 196                   #:parallel-build? ,parallel-build?
 197                   #:parallel-tests? ,parallel-tests?
 198                   #:patch-shebangs? ,patch-shebangs?
 199                   #:strip-binaries? ,strip-binaries?
 200                   #:strip-flags ,strip-flags
 201                   #:strip-directories ,strip-directories)))
 202
 203   (define guile-for-build
 204     (match guile
 205       ((? package?)
 206        (package-derivation store guile system))
 207       ((and (? string?) (? derivation-path?))
 208        guile)
 209       (#f                                         ; the default
 210        (let* ((distro (resolve-interface '(distro packages base)))
 211               (guile  (module-ref distro 'guile-final)))
 212          (package-derivation store guile system)))))
 213
 214   (build-expression->derivation store name system
 215                                 builder
 216                                 `(("source" ,source)
 217                                   ,@inputs
 218                                   ,@(if implicit-inputs?
 219                                         (parameterize ((%store store))
 220                                           (standard-inputs system))
 221                                         '()))
 222                                 #:outputs outputs
 223                                 #:modules imported-modules
 224                                 #:guile-for-build guile-for-build))
 225
 226 (define gnu-build-system
 227   (build-system (name 'gnu)
 228                 (description
 229                  "The GNU Build System—i.e., ./configure && make && make install")
 230                 (build gnu-build)))             ; TODO: add `gnu-cross-build'