code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system cargo)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%cargo-build-system-modules
            %cargo-utils-modules
            cargo-build-system
            %crate-base-url
            crate-url
            crate-url?
            crate-uri))

(define %crate-base-url
  (make-parameter "https://crates.io"))
(define crate-url
  (string-append (%crate-base-url) "/api/v1/crates/"))
(define crate-url?
  (cut string-prefix? crate-url <>))

(define (crate-uri name version)
  "Return a URI string for the crate package hosted at crates.io corresponding
to NAME and VERSION."
  (string-append crate-url name "/" version "/download"))

(define (default-rust)
  "Return the default Rust package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((rust (resolve-interface '(gnu packages rust))))
    (module-ref rust 'rust)))

(define %cargo-utils-modules
  ;; Build-side modules imported by default.
  `((guix build cargo-utils)
    ,@%gnu-build-system-modules))

(define %cargo-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build cargo-build-system)
    (guix build json)
    ,@%cargo-utils-modules))

(define* (cargo-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (vendor-dir "guix-vendor")
                      (cargo-build-flags ''("--release"))
                      (cargo-test-flags ''("--release"))
                      (features ''())
                      (skip-build? #f)
                      (phases '(@ (guix build cargo-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %cargo-build-system-modules)
                      (modules '((guix build cargo-build-system)
                                 (guix build utils))))
  "Build SOURCE using CARGO, and with INPUTS."

  (define builder
    `(begin
       (use-modules ,@modules)
       (cargo-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:vendor-dir ,vendor-dir
                    #:cargo-build-flags ,cargo-build-flags
                    #:cargo-test-flags ,cargo-test-flags
                    #:features ,features
                    #:skip-build? ,skip-build?
                    #:tests? ,(and tests? (not skip-build?))
                    #:phases ,phases
                    #:outputs %outputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define (package-cargo-inputs p)
  (apply
    (lambda* (#:key (cargo-inputs '()) #:allow-other-keys)
      cargo-inputs)
    (package-arguments p)))

(define (package-cargo-development-inputs p)
  (apply
    (lambda* (#:key (cargo-development-inputs '()) #:allow-other-keys)
      cargo-development-inputs)
    (package-arguments p)))

(define (crate-closure inputs)
  "Return the closure of INPUTS when considering the 'cargo-inputs' and
'cargod-dev-deps' edges.  Omit duplicate inputs, except for those
already present in INPUTS itself.

This is implemented as a breadth-first traversal such that INPUTS is
preserved, and only duplicate extracted inputs are removed.

Forked from ((guix packages) transitive-inputs) since this extraction
uses slightly different rules compared to the rest of Guix (i.e. we
do not extract the conventional inputs)."
  (define (seen? seen item)
    ;; FIXME: We're using pointer identity here, which is extremely sensitive
    ;; to memoization in package-producing procedures; see
    ;; <https://bugs.gnu.org/30155>.
    (vhash-assq item seen))

  (let loop ((inputs     inputs)
             (result     '())
             (propagated '())
             (first?     #t)
             (seen       vlist-null))
    (match inputs
      (()
       (if (null? propagated)
           (reverse result)
           (loop (reverse (concatenate propagated)) result '() #f seen)))
      (((and input (label (? package? package))) rest ...)
       (if (and (not first?) (seen? seen package))
           (loop rest result propagated first? seen)
           (loop rest
                 (cons input result)
                 (cons (package-cargo-inputs package)
                       propagated)
                 first?
                 (vhash-consq package package seen))))
      ((input rest ...)
       (loop rest (cons input result) propagated first? seen)))))

(define (expand-crate-sources cargo-inputs cargo-development-inputs)
  "Extract all transitive sources for CARGO-INPUTS and CARGO-DEVELOPMENT-INPUTS
along their 'cargo-inputs' edges.

Cargo requires all transitive crate dependencies' sources to be available
in its index, even if they are optional (this is so it can generate
deterministic Cargo.lock files regardless of the target platform or enabled
features). Thus we need all transitive crate dependencies for any cargo
dev-dependencies, but this is only needed when building/testing a crate directly
(i.e. we will never need transitive dev-dependencies for any dependency crates).

Another complication arises due potential dependency cycles from Guix's
perspective: Although cargo does not permit cyclic dependencies between crates,
however, it permits cycles to occur via dev-dependencies. For example, if crate
X depends on crate Y, crate Y's tests could pull in crate X to to verify
everything builds properly (this is a rare scenario, but it it happens for
example with the `proc-macro2` and `quote` crates). This is allowed by cargo
because tests are built as a pseudo-crate which happens to depend on the
X and Y crates, forming an acyclic graph.

We can side step this problem by only considering regular cargo dependencies
since they are guaranteed to not have cycles. We can further resolve any
potential dev-dependency cycles by extracting package sources (which never have
any dependencies and thus no cycles can exist).

There are several implications of this decision:
* Building a package definition does not require actually building/checking
any dependent crates. This can be a benefits:
 - For example, sometimes a crate may have an optional dependency on some OS
 specific package which cannot be built or run on the current system. This
 approach means that the build will not fail if cargo ends up internally ignoring
 the dependency.
 - It avoids waiting for quadratic builds from source: cargo always builds
 dependencies within the current workspace. This is largely due to Rust not
 having a stable ABI and other resolutions that cargo applies. This means that
 if we have a depencency chain of X -> Y -> Z and we build each definition
 independently the following will happen:
  * Cargo will build and test crate Z
  * Cargo will build crate Z in Y's workspace, then build and test Y
  * Cargo will build crates Y and Z in X's workspace, then build and test X
* But there are also some downsides with this approach:
  - If a dependent crate is subtly broken on the system (i.e. it builds but its
  tests fail) the consuming crates may build and test successfully but
  actually fail during normal usage (however, the CI will still build all
  packages which will give visibility in case packages suddenly break).
  - Because crates aren't declared as regular inputs, other Guix facilities
  such as tracking package graphs may not work by default (however, this is
  something that can always be extended or reworked in the future)."
  (filter-map
    (match-lambda
      ((label (? package? p))
       (list label (package-source p)))
      ((label input)
       (list label input)))
    (crate-closure (append cargo-inputs cargo-development-inputs))))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (rust (default-rust))
                (cargo-inputs '())
                (cargo-development-inputs '())
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."

  (define private-keywords
    '(#:source #:target #:rust #:inputs #:native-inputs #:outputs
      #:cargo-inputs #:cargo-development-inputs))

  (and (not target) ;; TODO: support cross-compilation
       (bag
         (name name)
         (system system)
         (target target)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("cargo" ,rust "cargo")
                         ("rustc" ,rust)
                         ,@(expand-crate-sources cargo-inputs cargo-development-inputs)
                         ,@native-inputs))
         (outputs outputs)
         (build cargo-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define cargo-build-system
  (build-system
    (name 'cargo)
    (description
     "Cargo build system, to build Rust crates")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system clojure)
  #:use-module (guix build clojure-utils)
  #:use-module (guix build-system)
  #:use-module (guix build-system ant)
  #:use-module ((guix build-system gnu)
                #:select (standard-packages)
                #:prefix gnu:)

  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module ((guix search-paths)
                #:select
                ((search-path-specification->sexp . search-path-spec->sexp)))
  #:use-module (guix utils)

  #:use-module (ice-9 match)
  #:export (%clojure-build-system-modules
            clojure-build
            clojure-build-system))

;; Commentary:
;;
;; Standard build procedure for Clojure packages.
;;
;; Code:

(define-with-docs %clojure-build-system-modules
  "Build-side modules imported by default."
  `((guix build clojure-build-system)
    (guix build clojure-utils)
    (guix build guile-build-system)
    ,@%ant-build-system-modules))

(define %default-modules
  ;; Modules in scope in the build-side environment.
  '((guix build clojure-build-system)
    (guix build clojure-utils)
    (guix build utils)))

(define-with-docs %default-clojure
  "The default Clojure package."
  (delay (@* (gnu packages clojure) clojure)))

(define-with-docs %default-jdk
  "The default JDK package."
  (delay (@* (gnu packages java) icedtea)))

(define-with-docs %default-zip
  "The default ZIP package."
  (delay (@* (gnu packages compression) zip)))

(define* (lower name
                #:key
                source target
                inputs native-inputs
                (clojure (force %default-clojure))
                (jdk (force %default-jdk))
                (zip (force %default-zip))
                outputs system
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (let ((private-keywords '(#:source #:target
                            #:inputs #:native-inputs
                            #:clojure #:jdk #:zip)))

    (if target
        (error "No cross-compilation for clojure-build-system yet: LOWER"
               target) ; FIXME
        (bag (name name)
             (system system)
             (host-inputs `(,@(if source
                                  `(("source" ,source))
                                  '())
                            ,@inputs
                            ,@(gnu:standard-packages)))
             (build-inputs `(("clojure" ,clojure)
                             ("jdk" ,jdk "jdk")
                             ("zip" ,zip)
                             ,@native-inputs))
             (outputs outputs)
             (build clojure-build)
             (arguments (strip-keyword-arguments private-keywords
                                                 arguments))))))

(define-with-docs source->output-path
  "Convert source input to output path."
  (match-lambda
    (((? derivation? source))
     (derivation->output-path source))
    ((source)
     source)
    (source
     source)))

(define-with-docs maybe-guile->guile
  "Find the right guile."
  (match-lambda
    ((and maybe-guile (? package?))
     maybe-guile)
    (#f ; default
     (@* (gnu packages commencement) guile-final))))

(define* (clojure-build store name inputs
                        #:key
                        (source-dirs `',%source-dirs)
                        (test-dirs `',%test-dirs)
                        (compile-dir %compile-dir)

                        (jar-names `',(package-name->jar-names name))
                        (main-class %main-class)
                        (omit-source? %omit-source?)

                        (aot-include `',%aot-include)
                        (aot-exclude `',%aot-exclude)

                        doc-dirs ; no sensible default
                        (doc-regex %doc-regex)

                        (tests? %tests?)
                        (test-include `',%test-include)
                        (test-exclude `',%test-exclude)

                        (phases '%standard-phases)
                        (outputs '("out"))
                        (search-paths '())
                        (system (%current-system))
                        (guile #f)

                        (imported-modules %clojure-build-system-modules)
                        (modules %default-modules))
  "Build SOURCE with INPUTS."
  (let ((builder `(begin
                    (use-modules ,@modules)
                    (clojure-build #:name ,name
                                   #:source ,(source->output-path
                                              (assoc-ref inputs "source"))

                                   #:source-dirs ,source-dirs
                                   #:test-dirs ,test-dirs
                                   #:compile-dir ,compile-dir

                                   #:jar-names ,jar-names
                                   #:main-class ,main-class
                                   #:omit-source? ,omit-source?

                                   #:aot-include ,aot-include
                                   #:aot-exclude ,aot-exclude

                                   #:doc-dirs ,doc-dirs
                                   #:doc-regex ,doc-regex

                                   #:tests? ,tests?
                                   #:test-include ,test-include
                                   #:test-exclude ,test-exclude

                                   #:phases ,phases
                                   #:outputs %outputs
                                   #:search-paths ',(map search-path-spec->sexp
                                                         search-paths)
                                   #:system ,system
                                   #:inputs %build-inputs)))

        (guile-for-build (package-derivation store
                                             (maybe-guile->guile guile)
                                             system
                                             #:graft? #f)))

    (build-expression->derivation store name builder
                                  #:inputs inputs
                                  #:system system
                                  #:modules imported-modules
                                  #:outputs outputs
                                  #:guile-for-build guile-for-build)))

(define clojure-build-system
  (build-system
    (name 'clojure)
    (description "Simple Clojure build system using plain old 'compile'")
    (lower lower)))

;;; clojure.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system cmake)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:export (%cmake-build-system-modules
            cmake-build
            cmake-build-system))

;; Commentary:
;;
;; Standard build procedure for packages using CMake. This is implemented as an
;; extension of `gnu-build-system'.
;;
;; Code:

(define %cmake-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build cmake-build-system)
    ,@%gnu-build-system-modules))

(define (default-cmake target)
  "Return the default CMake package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages cmake))))
    (module-ref module
                (if target
                    'cmake-minimal-cross
                    'cmake-minimal))))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (cmake (default-cmake target))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    `(#:source #:cmake #:inputs #:native-inputs #:outputs
      ,@(if target '() '(#:target))))

  (bag
    (name name)
    (system system)
    (target target)
    (build-inputs `(,@(if source
                          `(("source" ,source))
                          '())
                    ,@`(("cmake" ,cmake))
                    ,@native-inputs
                    ,@(if target '() inputs)
                    ,@(if target
                          ;; Use the standard cross inputs of
                          ;; 'gnu-build-system'.
                          (standard-cross-packages target 'host)
                          '())
                    ;; Keep the standard inputs of 'gnu-build-system'.
                    ,@(standard-packages)))
    (host-inputs (if target inputs '()))

    ;; The cross-libc is really a target package, but for bootstrapping
    ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
    ;; native package, so it would end up using a "native" variant of
    ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
    ;; would use a target variant (built with 'gnu-cross-build'.)
    (target-inputs (if target
                       (standard-cross-packages target 'target)
                       '()))
    (outputs outputs)
    (build (if target cmake-cross-build cmake-build))
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (cmake-build store name inputs
                      #:key (guile #f)
                      (outputs '("out")) (configure-flags ''())
                      (search-paths '())
                      (make-flags ''())
                      (out-of-source? #t)
                      (build-type "RelWithDebInfo")
                      (tests? #t)
                      (test-target "test")
                      (parallel-build? #t) (parallel-tests? #t)
                      (validate-runpath? #t)
                      (patch-shebangs? #t)
                      (strip-binaries? #t)
                      (strip-flags ''("--strip-debug"))
                      (strip-directories ''("lib" "lib64" "libexec"
                                            "bin" "sbin"))
                      (phases '(@ (guix build cmake-build-system)
                                  %standard-phases))
                      (system (%current-system))
                      (substitutable? #t)
                      (imported-modules %cmake-build-system-modules)
                      (modules '((guix build cmake-build-system)
                                 (guix build utils))))
  "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE
provides a 'CMakeLists.txt' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (cmake-build #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:outputs %outputs
                    #:inputs %build-inputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:phases ,phases
                    #:configure-flags ,configure-flags
                    #:make-flags ,make-flags
                    #:out-of-source? ,out-of-source?
                    #:build-type ,build-type
                    #:tests? ,tests?
                    #:test-target ,test-target
                    #:parallel-build? ,parallel-build?
                    #:parallel-tests? ,parallel-tests?
                    #:validate-runpath? ,validate-runpath?
                    #:patch-shebangs? ,patch-shebangs?
                    #:strip-binaries? ,strip-binaries?
                    #:strip-flags ,strip-flags
                    #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:substitutable? substitutable?
                                #:guile-for-build guile-for-build))

;;;
;;; Cross-compilation.
;;;

(define* (cmake-cross-build store name
                            #:key
                            target native-drvs target-drvs
                            (guile #f)
                            (outputs '("out"))
                            (configure-flags ''())
                            (search-paths '())
                            (native-search-paths '())
                            (make-flags ''())
                            (out-of-source? #t)
                            (build-type "RelWithDebInfo")
                            (tests? #f) ; nothing can be done
                            (test-target "test")
                            (parallel-build? #t) (parallel-tests? #t)
                            (validate-runpath? #t)
                            (patch-shebangs? #t)
                            (strip-binaries? #t)
                            (strip-flags ''("--strip-debug"
                                            "--enable-deterministic-archives"))
                            (strip-directories ''("lib" "lib64" "libexec"
                                                  "bin" "sbin"))
                            (phases '(@ (guix build cmake-build-system)
                                        %standard-phases))
                            (substitutable? #t)
                            (system (%current-system))
                            (build (nix-system->gnu-triplet system))
                            (imported-modules %cmake-build-system-modules)
                            (modules '((guix build cmake-build-system)
                                       (guix build utils))))
  "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and
with INPUTS.  This assumes that SOURCE provides a 'CMakeLists.txt' file as its
build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (let ()
         (define %build-host-inputs
           ',(map (match-lambda
                    ((name (? derivation? drv) sub ...)
                     `(,name . ,(apply derivation->output-path drv sub)))
                    ((name path)
                     `(,name . ,path)))
                  native-drvs))

         (define %build-target-inputs
           ',(map (match-lambda
                    ((name (? derivation? drv) sub ...)
                     `(,name . ,(apply derivation->output-path drv sub)))
                    ((name (? package? pkg) sub ...)
                     (let ((drv (package-cross-derivation store pkg
                                                          target system)))
                       `(,name . ,(apply derivation->output-path drv sub))))
                    ((name path)
                     `(,name . ,path)))
                  target-drvs))

         (cmake-build #:source ,(match (assoc-ref native-drvs "source")
                                  (((? derivation? source))
                                   (derivation->output-path source))
                                  ((source)
                                   source)
                                  (source
                                   source))
                      #:system ,system
                      #:build ,build
                      #:target ,target
                      #:outputs %outputs
                      #:inputs %build-target-inputs
                      #:native-inputs %build-host-inputs
                      #:search-paths ',(map search-path-specification->sexp
                                            search-paths)
                      #:native-search-paths ',(map
                                               search-path-specification->sexp
                                               native-search-paths)
                      #:phases ,phases
                      #:configure-flags ,configure-flags
                      #:make-flags ,make-flags
                      #:out-of-source? ,out-of-source?
                      #:build-type ,build-type
                      #:tests? ,tests?
                      #:test-target ,test-target
                      #:parallel-build? ,parallel-build?
                      #:parallel-tests? ,parallel-tests?
                      #:validate-runpath? ,validate-runpath?
                      #:patch-shebangs? ,patch-shebangs?
                      #:strip-binaries? ,strip-binaries?
                      #:strip-flags ,strip-flags
                      #:strip-directories ,strip-directories))))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                               ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs (append native-drvs target-drvs)
                                #:outputs outputs
                                #:modules imported-modules
                                #:substitutable? substitutable?
                                #:guile-for-build guile-for-build))

(define cmake-build-system
  (build-system
    (name 'cmake)
    (description "The standard CMake build system")
    (lower lower)))

;;; cmake.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system copy)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%copy-build-system-modules
            default-glibc
            lower
            copy-build
            copy-build-system))

;; Commentary:
;;
;; Standard build procedure for simple packages that don't require much
;; compilation, mostly just copying files around.  This is implemented as an
;; extension of `gnu-build-system'.
;;
;; Code:

(define %copy-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build copy-build-system)
    ,@%gnu-build-system-modules))

(define (default-glibc)
  "Return the default glibc package."
  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages base))))
    (module-ref module 'glibc)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (glibc (default-glibc))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME from the given arguments."
  (define private-keywords
    '(#:source #:target #:inputs #:native-inputs))

  (bag
    (name name)
    (system system)
    (host-inputs `(,@(if source
                         `(("source" ,source))
                         '())
                   ,@inputs
                   ;; Keep the standard inputs of 'gnu-build-system'.
                   ,@(standard-packages)))
    (build-inputs native-inputs)
    (outputs outputs)
    (build copy-build)
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (copy-build store name inputs
                     #:key (guile #f)
                     (outputs '("out"))
                     (install-plan ''(("." "./")))
                     (search-paths '())
                     (out-of-source? #t)
                     (validate-runpath? #t)
                     (patch-shebangs? #t)
                     (strip-binaries? #t)
                     (strip-flags ''("--strip-debug"))
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
                     (phases '(@ (guix build copy-build-system)
                                 %standard-phases))
                     (system (%current-system))
                     (imported-modules %copy-build-system-modules)
                     (modules '((guix build copy-build-system)
                                (guix build utils))))
  "Build SOURCE using INSTALL-PLAN, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (copy-build #:source ,(match (assoc-ref inputs "source")
                               (((?  derivation? source))
                                (derivation->output-path source))
                               ((source)
                                source)
                               (source
                                source))
                   #:system ,system
                   #:outputs %outputs
                   #:inputs %build-inputs
                   #:install-plan ,install-plan
                   #:search-paths ',(map search-path-specification->sexp
                                         search-paths)
                   #:phases ,phases
                   #:out-of-source? ,out-of-source?
                   #:validate-runpath? ,validate-runpath?
                   #:patch-shebangs? ,patch-shebangs?
                   #:strip-binaries? ,strip-binaries?
                   #:strip-flags ,strip-flags
                   #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define copy-build-system
  (build-system
    (name 'copy)
    (description "The standard copy build system")
    (lower lower)))

;;; copy.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system dub)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (dub-build-system))

(define (default-ldc)
  "Return the default ldc package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((ldc (resolve-interface '(gnu packages dlang))))
    (module-ref ldc 'ldc)))

(define (default-dub)
  "Return the default dub package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((ldc (resolve-interface '(gnu packages dlang))))
    (module-ref ldc 'dub)))

(define (default-pkg-config)
  "Return the default pkg-config package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((pkg-config (resolve-interface '(gnu packages pkg-config))))
    (module-ref pkg-config 'pkg-config)))

(define %dub-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build dub-build-system)
    (guix build syscalls)
    ,@%gnu-build-system-modules))

(define* (dub-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (dub-build-flags ''())
                      (phases '(@ (guix build dub-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %dub-build-system-modules)
                      (modules '((guix build dub-build-system)
                                 (guix build utils))))
  "Build SOURCE using DUB, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (dub-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:dub-build-flags ,dub-build-flags
                    #:tests? ,tests?
                    #:phases ,phases
                    #:outputs %outputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (ldc (default-ldc))
                (dub (default-dub))
                (pkg-config (default-pkg-config))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."

  (define private-keywords
    '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs))

  (and (not target) ;; TODO: support cross-compilation
       (bag
         (name name)
         (system system)
         (target target)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("ldc" ,ldc)
                         ("dub" ,dub)
                         ,@native-inputs))
         (outputs outputs)
         (build dub-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define dub-build-system
  (build-system
    (name 'dub)
    (description
     "DUB build system, to build D packages")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system dune)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module ((guix build-system gnu) #:prefix gnu:)
  #:use-module ((guix build-system ocaml) #:prefix ocaml:)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (%dune-build-system-modules
            dune-build
            dune-build-system))

;; Commentary:
;;
;; Standard build procedure for packages using dune. This is implemented as an
;; extension of `ocaml-build-system'.
;;
;; Code:

(define %dune-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build dune-build-system)
    ,@ocaml:%ocaml-build-system-modules))

(define (default-dune)
  "Return the default OCaml package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages ocaml))))
    (module-ref module 'dune)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (dune (default-dune))
                (ocaml (ocaml:default-ocaml))
                (findlib (ocaml:default-findlib))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs))

  (and (not target)                               ;XXX: no cross-compilation
       (let ((base (ocaml:lower name
                                #:source source
                                #:inputs inputs
                                #:native-inputs native-inputs
                                #:outputs outputs
                                #:system system
                                #:target target
                                #:ocaml ocaml
                                #:findlib findlib
                                arguments)))
         (bag
           (inherit base)
           (build-inputs `(("dune" ,dune)
                           ,@(bag-build-inputs base)))
           (build dune-build)
           (arguments (strip-keyword-arguments private-keywords arguments))))))

(define* (dune-build store name inputs
                     #:key (guile #f)
                     (outputs '("out"))
                     (search-paths '())
                     (build-flags ''())
                     (out-of-source? #t)
                     (jbuild? #f)
                     (package #f)
                     (tests? #t)
                     (test-flags ''())
                     (test-target "test")
                     (install-target "install")
                     (validate-runpath? #t)
                     (patch-shebangs? #t)
                     (strip-binaries? #t)
                     (strip-flags ''("--strip-debug"))
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
                     (phases '(@ (guix build dune-build-system)
                                 %standard-phases))
                     (system (%current-system))
                     (imported-modules %dune-build-system-modules)
                     (modules '((guix build dune-build-system)
                                (guix build utils))))
  "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE
provides a 'setup.ml' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (dune-build #:source ,(match (assoc-ref inputs "source")
                               (((? derivation? source))
                                (derivation->output-path source))
                               ((source)
                                source)
                               (source
                                source))
                   #:system ,system
                   #:outputs %outputs
                   #:inputs %build-inputs
                   #:search-paths ',(map search-path-specification->sexp
                                         search-paths)
                   #:phases ,phases
                   #:test-flags ,test-flags
                   #:build-flags ,build-flags
                   #:out-of-source? ,out-of-source?
                   #:jbuild? ,jbuild?
                   #:package ,package
                   #:tests? ,tests?
                   #:test-target ,test-target
                   #:install-target ,install-target
                   #:validate-runpath? ,validate-runpath?
                   #:patch-shebangs? ,patch-shebangs?
                   #:strip-binaries? ,strip-binaries?
                   #:strip-flags ,strip-flags
                   #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define dune-build-system
  (build-system
    (name 'dune)
    (description "The standard Dune build system")
    (lower lower)))

;;; dune.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system emacs)
  #:use-module ((guix build emacs-build-system)
                #:select (%default-include %default-exclude))
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (%emacs-build-system-modules
            emacs-build
            emacs-build-system)
  #:re-export (%default-include         ;for convenience
               %default-exclude))

;; Commentary:
;;
;; Standard build procedure for Emacs packages.  This is implemented as an
;; extension of 'gnu-build-system'.
;;
;; Code:

(define %emacs-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build emacs-build-system)
    (guix build emacs-utils)
    ,@%gnu-build-system-modules))

(define (default-emacs)
  "Return the default Emacs package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((emacs-mod (resolve-interface '(gnu packages emacs))))
    (module-ref emacs-mod 'emacs-minimal)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (emacs (default-emacs))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:target #:emacs #:inputs #:native-inputs))

  (and (not target)                               ;XXX: no cross-compilation
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'.
                        ,@(standard-packages)))
         (build-inputs `(("emacs" ,emacs)
                         ,@native-inputs))
         (outputs outputs)
         (build emacs-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (emacs-build store name inputs
                      #:key source
                      (tests? #f)
                      (parallel-tests? #t)
                      (test-command ''("make" "check"))
                      (phases '(@ (guix build emacs-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (include (quote %default-include))
                      (exclude (quote %default-exclude))
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %emacs-build-system-modules)
                      (modules '((guix build emacs-build-system)
                                 (guix build utils)
                                 (guix build emacs-utils))))
  "Build SOURCE using EMACS, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (emacs-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-command ,test-command
                    #:tests? ,tests?
                    #:parallel-tests? ,parallel-tests?
                    #:phases ,phases
                    #:outputs %outputs
                    #:include ,include
                    #:exclude ,exclude
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define emacs-build-system
  (build-system
    (name 'emacs)
    (description "The build system for Emacs packages")
    (lower lower)))

;;; emacs.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system font)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:export (%font-build-system-modules
            font-build
            font-build-system))

;; Commentary:
;;
;; Standard build procedure for fonts.  This is implemented as an extension of
;; 'gnu-build-system'.
;;
;; Code:

(define %font-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build font-build-system)
    ,@%gnu-build-system-modules))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:target #:inputs #:native-inputs))

  (bag
    (name name)
    (system system)
    (host-inputs `(,@(if source
                         `(("source" ,source))
                         '())
                   ,@inputs
                   ,(list "tar" (module-ref (resolve-interface '(gnu packages base)) 'tar))
                   ,@(let ((compression (resolve-interface '(gnu packages compression))))
                       (map (match-lambda
                              ((name package)
                               (list name (module-ref compression package))))
                            `(("gzip" gzip)
                              ("bzip2" bzip2)
                              ("unzip" unzip)
                              ("xz" xz))))))
    (build-inputs native-inputs)
    (outputs outputs)
    (build font-build)
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define* (font-build store name inputs
                     #:key source
                     (tests? #t)
                     (test-target "test")
                     (configure-flags ''())
                     (phases '(@ (guix build font-build-system)
                                 %standard-phases))
                     (outputs '("out"))
                     (search-paths '())
                     (system (%current-system))
                     (guile #f)
                     (imported-modules %font-build-system-modules)
                     (modules '((guix build font-build-system)
                                (guix build utils))))
  "Build SOURCE with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (font-build #:name ,name
                   #:source ,(match (assoc-ref inputs "source")
                               (((? derivation? source))
                                (derivation->output-path source))
                               ((source)
                                source)
                               (source
                                source))
                   #:configure-flags ,configure-flags
                   #:system ,system
                   #:test-target ,test-target
                   #:tests? ,tests?
                   #:phases ,phases
                   #:outputs %outputs
                   #:search-paths ',(map search-path-specification->sexp
                                         search-paths)
                   #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define font-build-system
  (build-system
    (name 'font)
    (description "The build system for font packages")
    (lower lower)))

;;; font.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system glib-or-gtk)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:export (%glib-or-gtk-build-system-modules
            glib-or-gtk-build
            glib-or-gtk-build-system))

;; Commentary:
;;
;; This build system is an extension of the 'gnu-build-system'.  It
;; accomodates the needs of applications making use of glib or gtk+ (with "or"
;; to be interpreted in the mathematical sense).  This is achieved by adding
;; two phases run after the 'install' phase:
;;
;; 'glib-or-gtk-wrap' phase:
;;
;; a) This phase looks for GSettings schemas, GIO modules and theming data.
;; If any of these is found in any input package, then all programs in
;; "out/bin" are wrapped in scripts defining the nedessary environment
;; variables.
;;
;; b) Looks for the existence of "libdir/gtk-3.0" directories in all input
;; packages.  If any is found, then the environment variable "GTK_PATH" is
;; suitably set and added to the wrappers.  The variable "GTK_PATH" has been
;; preferred over "GTK_EXE_PREFIX" because the latter can only point to a
;; single directory, while we may need to point to several ones.
;;
;; 'glib-or-gtk-compile-schemas' phase:
;;
;; Looks for the presence of "out/share/glib-2.0/schemas".  If that directory
;; exists and does not include a file named "gschemas.compiled", then
;; "glib-compile-schemas" is run in that directory.
;;
;; Code:

(define %default-modules
  ;; Build-side modules made available in the build environment.
  '((guix build glib-or-gtk-build-system)
    (guix build utils)))

(define %glib-or-gtk-build-system-modules
  ;; Build-side modules imported and used by default.
  `((guix build glib-or-gtk-build-system)
    ,@%gnu-build-system-modules))

(define (default-glib)
  "Return the default glib package from which we use
\"glib-compile-schemas\"."
  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages glib))))
    (module-ref module 'glib)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (glib (default-glib))
                (implicit-inputs? #t)
                (strip-binaries? #t)
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:glib #:inputs #:native-inputs
      #:outputs #:implicit-inputs?))

  (and (not target)                               ;XXX: no cross-compilation
       (bag
         (name name)
         (system system)
         (host-inputs (if source
                          `(("source" ,source))
                          '()))
         (build-inputs `(,@native-inputs
                         ,@inputs
                         ("glib:bin" ,glib "bin") ; to compile schemas
                         ,@(if implicit-inputs?
                               (standard-packages)
                               '())))
         (outputs outputs)
         (build glib-or-gtk-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (glib-or-gtk-build store name inputs
                            #:key (guile #f)
                            (outputs '("out"))
                            (search-paths '())
                            (configure-flags ''())
                            ;; Disable icon theme cache generation.
                            (make-flags ''("gtk_update_icon_cache=true"))
                            (out-of-source? #f)
                            (tests? #t)
                            (test-target "check")
                            (parallel-build? #t)
                            (parallel-tests? #t)
                            (validate-runpath? #t)
                            (patch-shebangs? #t)
                            (strip-binaries? #t)
                            (strip-flags ''("--strip-debug"))
                            (strip-directories ''("lib" "lib64" "libexec"
                                                  "bin" "sbin"))
                            (phases '(@ (guix build glib-or-gtk-build-system)
                                        %standard-phases))
                            (glib-or-gtk-wrap-excluded-outputs ''())
                            (system (%current-system))
                            (imported-modules %glib-or-gtk-build-system-modules)
                            (modules %default-modules)
                            allowed-references
                            disallowed-references)
  "Build SOURCE with INPUTS.  See GNU-BUILD for more details."
  (define canonicalize-reference
    (match-lambda
     ((? package? p)
      (derivation->output-path (package-derivation store p system)))
     (((? package? p) output)
      (derivation->output-path (package-derivation store p system)
                               output))
     ((? string? output)
      output)))

  (define builder
    `(begin
       (use-modules ,@modules)
       (glib-or-gtk-build #:source ,(match (assoc-ref inputs "source")
                                      (((? derivation? source))
                                       (derivation->output-path source))
                                      ((source)
                                       source)
                                      (source
                                       source))
                          #:system ,system
                          #:outputs %outputs
                          #:inputs %build-inputs
                          #:search-paths ',(map search-path-specification->sexp
                                                search-paths)
                          #:phases ,phases
                          #:glib-or-gtk-wrap-excluded-outputs
                           ,glib-or-gtk-wrap-excluded-outputs
                          #:configure-flags ,configure-flags
                          #:make-flags ,make-flags
                          #:out-of-source? ,out-of-source?
                          #:tests? ,tests?
                          #:test-target ,test-target
                          #:parallel-build? ,parallel-build?
                          #:parallel-tests? ,parallel-tests?
                          #:validate-runpath? ,validate-runpath?
                          #:patch-shebangs? ,patch-shebangs?
                          #:strip-binaries? ,strip-binaries?
                          #:strip-flags ,strip-flags
                          #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs inputs
                                #:modules imported-modules
                                #:outputs outputs
                                #:allowed-references
                                (and allowed-references
                                     (map canonicalize-reference
                                          allowed-references))
                                #:disallowed-references
                                (and disallowed-references
                                     (map canonicalize-reference
                                          disallowed-references))
                                #:guile-for-build guile-for-build))

(define glib-or-gtk-build-system
  (build-system
    (name 'glib-or-gtk)
    (description
     "The GNU Build System—i.e., ./configure && make && make install,
augmented with definition of suitable environment variables for glib and gtk+
in program wrappers.")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system gnu)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix packages)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (%gnu-build-system-modules
            gnu-build
            gnu-build-system
            standard-packages
            standard-cross-packages
            package-with-explicit-inputs
            package-with-extra-configure-variable
            static-libgcc-package
            static-package
            dist-package
            package-with-restricted-references))

;; Commentary:
;;
;; Standard build procedure for packages using the GNU Build System or
;; something compatible ("./configure && make && make install").
;;
;; Code:

(define %gnu-build-system-modules
  ;; Build-side modules imported and used by default.
  '((guix build gnu-build-system)
    (guix build utils)
    (guix build gremlin)
    (guix elf)))

(define %default-modules
  ;; Modules in scope in the build-side environment.
  '((guix build gnu-build-system)
    (guix build utils)))

(define* (package-with-explicit-inputs/deprecated p inputs
                                                  #:optional
                                                  (loc (current-source-location))
                                                  #:key (native-inputs '())
                                                  guile)
  "This variant is deprecated because it is inefficient: it memoizes only
temporarily instead of memoizing across all transformations where INPUTS is
the same.

Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
it.  INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
latter case, they will be called in a context where the `%current-system' and
`%current-target-system' are suitably parametrized.  Use GUILE to run the
builder, or the distro's final Guile when GUILE is #f."
  (define inputs* inputs)
  (define native-inputs* native-inputs)

  (define (call inputs)
    (if (procedure? inputs)
        (inputs)
        inputs))

  (define (duplicate-filter inputs)
    (let ((names (match (call inputs)
                   (((name _ ...) ...)
                    name))))
      (lambda (inputs)
        (fold alist-delete inputs names))))

  (let loop ((p p))
    (define rewritten-input
      (mlambda (input)
        (match input
          ((name (? package? p) sub-drv ...)
           ;; XXX: Check whether P's build system knows #:implicit-inputs, for
           ;; things like `cross-pkg-config'.
           (if (eq? (package-build-system p) gnu-build-system)
               (cons* name (loop p) sub-drv)
               (cons* name p sub-drv)))
          (x x))))

    (package (inherit p)
      (location (if (pair? loc) (source-properties->location loc) loc))
      (arguments
       ;; 'ensure-keyword-arguments' guarantees that this procedure is
       ;; idempotent.
       (ensure-keyword-arguments (package-arguments p)
                                 `(#:guile ,guile
                                   #:implicit-inputs? #f)))
      (replacement
       (let ((replacement (package-replacement p)))
         (and replacement
              (package-with-explicit-inputs replacement inputs loc
                                            #:native-inputs
                                            native-inputs
                                            #:guile guile))))
      (native-inputs
       (let ((filtered (duplicate-filter native-inputs*)))
        `(,@(call native-inputs*)
          ,@(map rewritten-input
                 (filtered (package-native-inputs p))))))
      (propagated-inputs
       (map rewritten-input
            (package-propagated-inputs p)))
      (inputs
       (let ((filtered (duplicate-filter inputs*)))
         `(,@(call inputs*)
           ,@(map rewritten-input
                  (filtered (package-inputs p)))))))))

(define* (package-with-explicit-inputs* inputs #:optional guile)
  "Return a procedure that rewrites the given package and all its dependencies
so that they use INPUTS (a thunk) instead of implicit inputs."
  (define (duplicate-filter package-inputs)
    (let ((names (match (inputs)
                   (((name _ ...) ...)
                    name))))
      (fold alist-delete package-inputs names)))

  (define (add-explicit-inputs p)
    (if (and (eq? (package-build-system p) gnu-build-system)
             (not (memq #:implicit-inputs? (package-arguments p))))
        (package
          (inherit p)
          (inputs (append (inputs)
                          (duplicate-filter (package-inputs p))))
          (arguments
           (ensure-keyword-arguments (package-arguments p)
                                     `(#:implicit-inputs? #f
                                       #:guile ,guile))))
        p))

  (define (cut? p)
    (or (not (eq? (package-build-system p) gnu-build-system))
        (memq #:implicit-inputs? (package-arguments p))))

  (package-mapping add-explicit-inputs cut?))

(define package-with-explicit-inputs
  (case-lambda*
   ((inputs #:optional guile)
    (package-with-explicit-inputs* inputs guile))
   ((p inputs #:optional (loc (current-source-location))
       #:key (native-inputs '()) guile)
    ;; deprecated
    (package-with-explicit-inputs/deprecated p inputs
                                             loc
                                             #:native-inputs
                                             native-inputs
                                             #:guile guile))))

(define (package-with-extra-configure-variable p variable value)
  "Return a version of P with VARIABLE=VALUE specified as an extra `configure'
flag, recursively.  An example is LDFLAGS=-static.  If P already has configure
flags for VARIABLE, the associated value is augmented."
  (let loop ((p p))
    (define (rewritten-inputs inputs)
      (map (match-lambda
            ((name (? package? p) sub ...)
             `(,name ,(loop p) ,@sub))
            (input input))
           inputs))

    (package (inherit p)
      (arguments
       (let ((args (package-arguments p)))
         (substitute-keyword-arguments args
           ((#:configure-flags flags)
            (let* ((var= (string-append variable "="))
                   (len  (string-length var=)))
              `(cons ,(string-append var= value)
                     (map (lambda (flag)
                            (if (string-prefix? ,var= flag)
                                (string-append
                                 ,(string-append var= value " ")
                                 (substring flag ,len))
                                flag))
                          ,flags)))))))
      (replacement
       (let ((replacement (package-replacement p)))
         (and replacement
              (package-with-extra-configure-variable replacement
                                                     variable value))))
      (inputs (rewritten-inputs (package-inputs p)))
      (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))

(define (static-libgcc-package p)
  "A version of P linked with `-static-gcc'."
  (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc"))

(define* (static-package p #:key (strip-all? #t))
  "Return a statically-linked version of package P.  If STRIP-ALL? is true,
use `--strip-all' as the arguments to `strip'."
  (package (inherit p)
    (arguments
     (let ((a (default-keyword-arguments (package-arguments p)
                '(#:configure-flags '()
                  #:strip-flags '("--strip-unneeded")))))
       (substitute-keyword-arguments a
         ((#:configure-flags flags)
          `(cons* "--disable-shared" "LDFLAGS=-static" ,flags))
         ((#:strip-flags flags)
          (if strip-all?
              ''("--strip-all")
              flags)))))
    (replacement (and=> (package-replacement p) static-package))))

(define* (dist-package p source #:key (phases '%dist-phases))
  "Return a package that runs takes source files from the SOURCE directory,
runs `make distcheck' and whose result is one or more source tarballs.  The
exact build phases are defined by PHASES."
  (let ((s source))
    (package (inherit p)
      (name (string-append (package-name p) "-dist"))
      (source s)
      (arguments
       ;; Use the right phases and modules.
       (substitute-keyword-arguments (package-arguments p)
         ((#:modules modules %default-modules)
          `((guix build gnu-dist)
            ,@modules))
         ((#:imported-modules modules %gnu-build-system-modules)
          `((guix build gnu-dist)
            ,@modules))
         ((#:phases _ #f)
          phases)))
      (native-inputs
       ;; Add autotools & co. as inputs.
       (let ((ref (lambda (module var)
                    (module-ref (resolve-interface module) var))))
         `(,@(package-native-inputs p)
           ("autoconf" ,(ref '(gnu packages autotools) 'autoconf-wrapper))
           ("automake" ,(ref '(gnu packages autotools) 'automake))
           ("libtool"  ,(ref '(gnu packages autotools) 'libtool))
           ("gettext"  ,(ref '(gnu packages gettext) 'gnu-gettext))
           ("texinfo"  ,(ref '(gnu packages texinfo) 'texinfo))))))))

(define (package-with-restricted-references p refs)
  "Return a package whose outputs are guaranteed to only refer to the packages
listed in REFS."
  (if (eq? (package-build-system p) gnu-build-system) ; XXX: dirty
      (package (inherit p)
        (arguments `(#:allowed-references ,refs
                     ,@(package-arguments p))))
      p))

(define (standard-packages)
  "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of
standard packages used as implicit inputs of the GNU build system."

  ;; Resolve (gnu packages commencement) lazily to hide circular dependency.
  (let ((distro (resolve-module '(gnu packages commencement))))
    (module-ref distro '%final-inputs)))

(define* (lower name
                #:key source inputs native-inputs outputs target
                (implicit-inputs? #t) (implicit-cross-inputs? #t)
                (strip-binaries? #t) system
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME from the given arguments."
  (define private-keywords
    `(#:source #:inputs #:native-inputs #:outputs
      #:implicit-inputs? #:implicit-cross-inputs?
      ,@(if target '() '(#:target))))

  (bag
    (name name)
    (system system) (target target)
    (build-inputs `(,@(if source
                          `(("source" ,source))
                          '())
                    ,@native-inputs

                    ;; When not cross-compiling, ensure implicit inputs come
                    ;; last.  That way, libc headers come last, which allows
                    ;; #include_next to work correctly; see
                    ;; <https://bugs.gnu.org/30756>.
                    ,@(if target '() inputs)
                    ,@(if (and target implicit-cross-inputs?)
                          (standard-cross-packages target 'host)
                          '())
                    ,@(if implicit-inputs?
                          (standard-packages)
                          '())))
    (host-inputs (if target inputs '()))

    ;; The cross-libc is really a target package, but for bootstrapping
    ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
    ;; native package, so it would end up using a "native" variant of
    ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
    ;; would use a target variant (built with 'gnu-cross-build'.)
    (target-inputs (if (and target implicit-cross-inputs?)
                       (standard-cross-packages target 'target)
                       '()))
    (outputs (if strip-binaries?
                 outputs
                 (delete "debug" outputs)))
    (build (if target gnu-cross-build gnu-build))
    (arguments (strip-keyword-arguments private-keywords arguments))))

(define %license-file-regexp
  ;; Regexp matching license files.
  "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")

(define* (gnu-build store name input-drvs
                    #:key (guile #f)
                    (outputs '("out"))
                    (search-paths '())
                    (configure-flags ''())
                    (make-flags ''())
                    (out-of-source? #f)
                    (tests? #t)
                    (test-target "check")
                    (parallel-build? #t)
                    (parallel-tests? #t)
                    (patch-shebangs? #t)
                    (strip-binaries? #t)
                    (strip-flags ''("--strip-unneeded"
                                    "--enable-deterministic-archives"))
                    (strip-directories ''("lib" "lib64" "libexec"
                                          "bin" "sbin"))
                    (validate-runpath? #t)
                    (license-file-regexp %license-file-regexp)
                    (phases '%standard-phases)
                    (locale "en_US.utf8")
                    (system (%current-system))
                    (build (nix-system->gnu-triplet system))
                    (imported-modules %gnu-build-system-modules)
                    (modules %default-modules)
                    (substitutable? #t)
                    allowed-references
                    disallowed-references)
  "Return a derivation called NAME that builds from tarball SOURCE, with
input derivation INPUTS, using the usual procedure of the GNU Build
System.  The builder is run with GUILE, or with the distro's final Guile
package if GUILE is #f or omitted.

The builder is run in a context where MODULES are used; IMPORTED-MODULES
specifies modules not provided by Guile itself that must be imported in
the builder's environment, from the host.  Note that we distinguish
between both, because for Guile's own modules like (ice-9 foo), we want
to use GUILE's own version of it, rather than import the user's one,
which could lead to gratuitous input divergence.

SUBSTITUTABLE? determines whether users may be able to use substitutes of the
returned derivations, or whether they should always build it locally.

ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs
are allowed to refer to.  Likewise for DISALLOWED-REFERENCES, which lists
packages that must not be referenced."
  (define canonicalize-reference
    (match-lambda
     ((? package? p)
      (derivation->output-path (package-derivation store p system
                                                   #:graft? #f)))
     (((? package? p) output)
      (derivation->output-path (package-derivation store p system
                                                   #:graft? #f)
                               output))
     ((? string? output)
      output)))

  (define builder
    `(begin
       (use-modules ,@modules)
       (gnu-build #:source ,(match (assoc-ref input-drvs "source")
                              (((? derivation? source))
                               (derivation->output-path source))
                              ((source)
                               source)
                              (source
                               source))
                  #:system ,system
                  #:build ,build
                  #:outputs %outputs
                  #:inputs %build-inputs
                  #:search-paths ',(map search-path-specification->sexp
                                        search-paths)
                  #:phases ,phases
                  #:locale ,locale
                  #:configure-flags ,configure-flags
                  #:make-flags ,make-flags
                  #:out-of-source? ,out-of-source?
                  #:tests? ,tests?
                  #:test-target ,test-target
                  #:parallel-build? ,parallel-build?
                  #:parallel-tests? ,parallel-tests?
                  #:patch-shebangs? ,patch-shebangs?
                  #:strip-binaries? ,strip-binaries?
                  #:validate-runpath? ,validate-runpath?
                  #:license-file-regexp ,license-file-regexp
                  #:strip-flags ,strip-flags
                  #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system
                             #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs input-drvs
                                #:outputs outputs
                                #:modules imported-modules
                                #:substitutable? substitutable?

                                #:allowed-references
                                (and allowed-references
                                     (map canonicalize-reference
                                          allowed-references))
                                #:disallowed-references
                                (and disallowed-references
                                     (map canonicalize-reference
                                          disallowed-references))
                                #:guile-for-build guile-for-build))

;;;
;;; Cross-compilation.
;;;

(define standard-cross-packages
  (mlambda (target kind)
    "Return the list of name/package tuples to cross-build for TARGET.  KIND
is one of `host' or `target'."
    (let* ((cross     (resolve-interface '(gnu packages cross-base)))
           (gcc       (module-ref cross 'cross-gcc))
           (binutils  (module-ref cross 'cross-binutils))
           (libc      (module-ref cross 'cross-libc)))
      (case kind
        ((host)
         ;; Cross-GCC appears once here, so that it's in $PATH...
         `(("cross-gcc" ,(gcc target
                              #:xbinutils (binutils target)
                              #:libc (libc target)))
           ("cross-binutils" ,(binutils target))))
        ((target)
         (let ((libc (libc target)))
           ;; ... and once here, so that libstdc++ & co. are in
           ;; CROSS_CPLUS_INCLUDE_PATH, etc.
           `(("cross-gcc" ,(gcc target
                                #:xbinutils (binutils target)
                                #:libc libc))
             ("cross-libc" ,libc)

             ;; MinGW's libc doesn't have a "static" output.
             ,@(if (member "static" (package-outputs libc))
                   `(("cross-libc:static" ,libc "static"))
                   '()))))))))

(define* (gnu-cross-build store name
                          #:key
                          target native-drvs target-drvs
                          (guile #f)
                          source
                          (outputs '("out"))
                          (search-paths '())
                          (native-search-paths '())

                          (configure-flags ''())
                          (make-flags ''())
                          (out-of-source? #f)
                          (tests? #f)             ; nothing can be done
                          (test-target "check")
                          (parallel-build? #t) (parallel-tests? #t)
                          (patch-shebangs? #t)
                          (strip-binaries? #t)
                          (strip-flags ''("--strip-unneeded"
                                          "--enable-deterministic-archives"))
                          (strip-directories ''("lib" "lib64" "libexec"
                                                "bin" "sbin"))
                          (validate-runpath? #t)
                          (license-file-regexp %license-file-regexp)
                          (phases '%standard-phases)
                          (locale "en_US.utf8")
                          (system (%current-system))
                          (build (nix-system->gnu-triplet system))
                          (imported-modules %gnu-build-system-modules)
                          (modules %default-modules)
                          (substitutable? #t)
                          allowed-references
                          disallowed-references)
  "Cross-build NAME for TARGET, where TARGET is a GNU triplet.  INPUTS are
cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
platform."
  (define canonicalize-reference
    (match-lambda
     ((? package? p)
      (derivation->output-path (package-cross-derivation store p
                                                         target system)))
     (((? package? p) output)
      (derivation->output-path (package-cross-derivation store p
                                                         target system)
                               output))
     ((? string? output)
      output)))

  (define builder
    `(begin
       (use-modules ,@modules)

       (let ()
         (define %build-host-inputs
           ',(map (match-lambda
                   ((name (? derivation? drv) sub ...)
                    `(,name . ,(apply derivation->output-path drv sub)))
                   ((name path)
                    `(,name . ,path)))
                  native-drvs))

         (define %build-target-inputs
           ',(map (match-lambda
                   ((name (? derivation? drv) sub ...)
                    `(,name . ,(apply derivation->output-path drv sub)))
                   ((name (? package? pkg) sub ...)
                    (let ((drv (package-cross-derivation store pkg
                                                         target system)))
                      `(,name . ,(apply derivation->output-path drv sub))))
                   ((name path)
                    `(,name . ,path)))
                  target-drvs))

         (gnu-build #:source ,(match (assoc-ref native-drvs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:build ,build
                    #:target ,target
                    #:outputs %outputs
                    #:inputs %build-target-inputs
                    #:native-inputs %build-host-inputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:native-search-paths ',(map
                                             search-path-specification->sexp
                                             native-search-paths)
                    #:phases ,phases
                    #:locale ,locale
                    #:configure-flags ,configure-flags
                    #:make-flags ,make-flags
                    #:out-of-source? ,out-of-source?
                    #:tests? ,tests?
                    #:test-target ,test-target
                    #:parallel-build? ,parallel-build?
                    #:parallel-tests? ,parallel-tests?
                    #:patch-shebangs? ,patch-shebangs?
                    #:strip-binaries? ,strip-binaries?
                    #:validate-runpath? ,validate-runpath?
                    #:license-file-regexp ,license-file-regexp
                    #:strip-flags ,strip-flags
                    #:strip-directories ,strip-directories))))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:system system
                                #:inputs (append native-drvs target-drvs)
                                #:outputs outputs
                                #:modules imported-modules
                                #:substitutable? substitutable?

                                #:allowed-references
                                (and allowed-references
                                     (map canonicalize-reference
                                          allowed-references))
                                #:disallowed-references
                                (and disallowed-references
                                     (map canonicalize-reference
                                          disallowed-references))
                                #:guile-for-build guile-for-build))

(define gnu-build-system
  (build-system
    (name 'gnu)
    (description
     "The GNU Build System—i.e., ./configure && make && make install")
    (lower lower)))