Subject: bug#60056: [PATCH RFC 1/6] build: Add gnu-build-system v2.

From: Maxim Cournoyer <[email-masked]>
Date: Wed, 14 Dec 2022 22:23:23 -0500

* guix/build/gnu-build-system2.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/build-system/gnu2.scm: Use it.
---
 Makefile.am                      |   2 +
 guix/build-system/gnu2.scm       | 580 +++++++++++++++++++
 guix/build/gnu-build-system2.scm | 937 +++++++++++++++++++++++++++++++
 3 files changed, 1519 insertions(+)
 create mode 100644 guix/build-system/gnu2.scm
 create mode 100644 guix/build/gnu-build-system2.scm

diff --git a/Makefile.am b/Makefile.am
index b54288c0fc..a331385aa1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -159,6 +159,7 @@ MODULES =					\
   guix/build-system/copy.scm			\
   guix/build-system/glib-or-gtk.scm		\
   guix/build-system/gnu.scm			\
+  guix/build-system/gnu2.scm			\
   guix/build-system/guile.scm			\
   guix/build-system/haskell.scm			\
   guix/build-system/julia.scm			\
@@ -217,6 +218,7 @@ MODULES =					\
   guix/build/glib-or-gtk-build-system.scm	\
   guix/build/gnu-bootstrap.scm			\
   guix/build/gnu-build-system.scm		\
+  guix/build/gnu-build-system2.scm		\
   guix/build/gnu-dist.scm			\
   guix/build/guile-build-system.scm		\
   guix/build/maven-build-system.scm		\
diff --git a/guix/build-system/gnu2.scm b/guix/build-system/gnu2.scm
new file mode 100644
index 0000000000..95fce76714
--- /dev/null
+++ b/guix/build-system/gnu2.scm
@@ -0,0 +1,580 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012-2022 Ludovic Courtès <[email-masked]>
+;;;
+;;; 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 gnu2)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix memoization)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #: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-modules2
+            gnu-build2
+            gnu-build-system2
+            standard-packages2
+            standard-cross-packages2
+            package-with-explicit-inputs2
+            package-with-extra-configure-variable2
+            static-libgcc-package2
+            static-package2
+            dist-package2
+            package-with-restricted-references2))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using the GNU Build System or
+;; something compatible ("./configure && make && make install").
+;;
+;; Code:
+
+(define %gnu-build-system-modules2
+  ;; Build-side modules imported and used by default.
+  '((guix build gnu-build-system2)
+    (guix build utils)
+    (guix build gremlin)
+    (guix elf)))
+
+(define %default-modules
+  ;; Modules in scope in the build-side environment.
+  '((guix build gnu-build-system2)
+    (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-SYSTEM2, 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-system2)
+               (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-inputs2 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-system2)
+             (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-system2))
+        (memq #:implicit-inputs? (package-arguments p))))
+
+  (package-mapping add-explicit-inputs cut?))
+
+(define package-with-explicit-inputs2
+  (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-variable2 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-variable2 replacement
+                                                     variable value))))
+      (inputs (rewritten-inputs (package-inputs p)))
+      (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
+
+(define (static-libgcc-package2 p)
+  "A version of P linked with `-static-gcc'."
+  (package-with-extra-configure-variable2 p "LDFLAGS" "-static-libgcc"))
+
+(define* (static-package2 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-package2))))
+
+(define* (dist-package2 p source #:key (phases '%dist-phases))
+  "Return a package that 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-modules2)
+          `((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-references2 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-system2) ; XXX: dirty
+      (package (inherit p)
+        (arguments `(#:allowed-references ,refs
+                     ,@(package-arguments p))))
+      p))
+
+
+(define (standard-packages2)
+  "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of
+standard packages used as implicit inputs of the gnu-build-system2."
+
+  ;; 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
+    `(#: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-packages2 target 'host)
+                          '())
+                    ,@(if implicit-inputs?
+                          (standard-packages2)
+                          '())))
+    (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-packages2 target 'target)
+                       '()))
+    (outputs (if strip-binaries?
+                 outputs
+                 (delete "debug" outputs)))
+    (build (if target gnu-cross-build gnu-build2))
+    (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 %bootstrap-scripts
+  ;; Typical names of Autotools "bootstrap" scripts.
+  #~%bootstrap-scripts)
+
+(define %strip-flags
+  #~'("--strip-unneeded" "--enable-deterministic-archives"))
+
+(define %strip-directories
+  #~'("lib" "lib64" "libexec" "bin" "sbin"))
+
+(define* (gnu-build2 name inputs
+                     #:key
+                     guile source
+                     (outputs '("out"))
+                     (search-paths '())
+                     (bootstrap-scripts %bootstrap-scripts)
+                     (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-flags)
+                     (strip-directories %strip-directories)
+                     (validate-runpath? #t)
+                     (make-dynamic-linker-cache? #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-modules2)
+                     (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."
+  (define builder
+    (with-imported-modules imported-modules
+      #~(begin
+          (use-modules #$@(sexp->gexp modules))
+
+          #$(with-build-variables inputs outputs
+              #~(gnu-build2 #:source #+source
+                            #:system #$system
+                            #:build #$build
+                            #:outputs %outputs
+                            #:inputs %build-inputs
+                            #:search-paths '#$(sexp->gexp
+                                               (map search-path-specification->sexp
+                                                    search-paths))
+                            #:phases #$(if (pair? phases)
+                                           (sexp->gexp phases)
+                                           phases)
+                            #:locale #$locale
+                            #:bootstrap-scripts #$bootstrap-scripts
+                            #:configure-flags #$(if (pair? configure-flags)
+                                                    (sexp->gexp configure-flags)
+                                                    configure-flags)
+                            #:make-flags #$(if (pair? make-flags)
+                                               (sexp->gexp 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?
+                            #:license-file-regexp #$license-file-regexp
+                            #:strip-binaries? #$strip-binaries?
+                            #:validate-runpath? #$validate-runpath?
+                            #:make-dynamic-linker-cache? #$make-dynamic-linker-cache?
+                            #:license-file-regexp #$license-file-regexp
+                            #:strip-flags #$strip-flags
+                            #:strip-directories #$strip-directories)))))
+
+  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+                                                  system #:graft? #f)))
+    ;; Note: Always pass #:graft? #f.  Without it, ALLOWED-REFERENCES &
+    ;; co. would be interpreted as referring to grafted packages.
+    (gexp->derivation name builder
+                      #:system system
+                      #:target #f
+                      #:graft? #f
+                      #:substitutable? substitutable?
+                      #:allowed-references allowed-references
+                      #:disallowed-references disallowed-references
+                      #:guile-for-build guile)))
+
+
+;;;
+;;; Cross-compilation.
+;;;
+
+(define standard-cross-packages2
+  (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 name
+                          #:key
+                          target
+                          build-inputs target-inputs host-inputs
+                          guile source
+                          (outputs '("out"))
+                          (search-paths '())
+                          (native-search-paths '())
+
+                          (bootstrap-scripts %bootstrap-scripts)
+                          (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-flags)
+                          (strip-directories %strip-directories)
+                          (validate-runpath? #t)
+
+                          ;; We run 'ldconfig' to generate ld.so.cache and it
+                          ;; generally can't do that for cross-built binaries
+                          ;; ("ldconfig: foo.so is for unknown machine 40.").
+                          (make-dynamic-linker-cache? #f)
+
+                          (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-modules2)
+                          (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 builder
+    #~(begin
+        (use-modules #$@(sexp->gexp modules))
+
+        (define %build-host-inputs
+          #+(input-tuples->gexp build-inputs))
+
+        (define %build-target-inputs
+          (append #$(input-tuples->gexp host-inputs)
+                  #+(input-tuples->gexp target-inputs)))
+
+        (define %build-inputs
+          (append %build-host-inputs %build-target-inputs))
+
+        (define %outputs
+          #$(outputs->gexp outputs))
+
+        (gnu-build2 #:source #+source
+                    #:system #$system
+                    #:build #$build
+                    #:target #$target
+                    #:outputs %outputs
+                    #:inputs %build-target-inputs
+                    #:native-inputs %build-host-inputs
+                    #:search-paths '#$(sexp->gexp
+                                       (map search-path-specification->sexp
+                                            search-paths))
+                    #:native-search-paths '#$(sexp->gexp
+                                              (map
+                                               search-path-specification->sexp
+                                               native-search-paths))
+                    #:phases #$(if (pair? phases)
+                                   (sexp->gexp phases)
+                                   phases)
+                    #:locale #$locale
+                    #:bootstrap-scripts #$bootstrap-scripts
+                    #: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?
+                    #:license-file-regexp #$license-file-regexp
+                    #:strip-binaries? #$strip-binaries?
+                    #:validate-runpath? #$validate-runpath?
+                    #:make-dynamic-linker-cache? #$make-dynamic-linker-cache?
+                    #:license-file-regexp #$license-file-regexp
+                    #:strip-flags #$strip-flags
+                    #:strip-directories #$strip-directories)))
+
+  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+                                                  system #:graft? #f)))
+    (gexp->derivation name builder
+                      #:system system
+                      #:target target
+                      #:graft? #f
+                      #:modules imported-modules
+                      #:substitutable? substitutable?
+                      #:allowed-references allowed-references
+                      #:disallowed-references disallowed-references
+                      #:guile-for-build guile)))
+
+(define gnu-build-system2
+  (build-system
+    (name 'gnu)
+    (description
+     "The GNU Build System—i.e., ./configure && make && make install")
+    (lower lower)))
diff --git a/guix/build/gnu-build-system2.scm b/guix/build/gnu-build-system2.scm
new file mode 100644
index 0000000000..54129549c2
--- /dev/null
+++ b/guix/build/gnu-build-system2.scm
@@ -0,0 +1,937 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2018 Mark H Weaver <[email-masked]>
+;;; Copyright © 2020 Brendan Tildesley <[email-masked]>
+;;; Copyright © 2021 Maxim Cournoyer <[email-masked]>
+;;;
+;;; 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 gnu-build-system2)
+  #:use-module (guix build utils)
+  #:use-module (guix build gremlin)
+  #:use-module (guix elf)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
+  #:export (%standard-phases
+            %license-file-regexp
+            %bootstrap-scripts
+            dump-file-contents
+            gnu-build2))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using the GNU Build System or
+;; something compatible ("./configure && make && make install").  This is the
+;; builder-side code.
+;;
+;; Code:
+
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
+(define* (set-SOURCE-DATE-EPOCH #:rest _)
+  "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
+that incorporate timestamps as a way to tell them to use a fixed timestamp.
+See https://reproducible-builds.org/specs/source-date-epoch/."
+  (setenv "SOURCE_DATE_EPOCH" "1"))
+
+(define (first-subdirectory directory)
+  "Return the file name of the first sub-directory of DIRECTORY or false, when
+there are none."
+  (match (scandir directory
+                  (lambda (file)
+                    (and (not (member file '("." "..")))
+                         (file-is-directory? (string-append directory "/"
+                                                            file)))))
+    ((first . _) first)
+    (_ #f)))
+
+(define* (set-paths #:key target inputs native-inputs
+                    (search-paths '()) (native-search-paths '())
+                    #:allow-other-keys)
+  (define input-directories
+    ;; The "source" input can be a directory, but we don't want it for search
+    ;; paths.  See <https://issues.guix.gnu.org/44924>.
+    (match (alist-delete "source" inputs)
+      (((_ . dir) ...)
+       dir)))
+
+  (define native-input-directories
+    (match native-inputs
+      (((_ . dir) ...)
+       dir)
+      (#f                                         ; not cross compiling
+       '())))
+
+  ;; Tell 'ld-wrapper' to disallow non-store libraries.
+  (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no")
+
+  ;; When cross building, $PATH must refer only to native (host) inputs since
+  ;; target inputs are not executable.
+  (set-path-environment-variable "PATH" '("bin" "sbin")
+                                 (append native-input-directories
+                                         (if target
+                                             '()
+                                             input-directories)))
+
+  (for-each (match-lambda
+             ((env-var (files ...) separator type pattern)
+              (set-path-environment-variable env-var files
+                                             input-directories
+                                             #:separator separator
+                                             #:type type
+                                             #:pattern pattern)))
+            search-paths)
+
+  (when native-search-paths
+    ;; Search paths for native inputs, when cross building.
+    (for-each (match-lambda
+               ((env-var (files ...) separator type pattern)
+                (set-path-environment-variable env-var files
+                                               native-input-directories
+                                               #:separator separator
+                                               #:type type
+                                               #:pattern pattern)))
+              native-search-paths)))
+
+(define* (install-locale #:key
+                         (locale "en_US.utf8")
+                         (locale-category LC_ALL)
+                         #:allow-other-keys)
+  "Try to install LOCALE; emit a warning if that fails.  The main goal is to
+use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.
+
+This phase must typically happen after 'set-paths' so that $LOCPATH has a
+chance to be set."
+  (catch 'system-error
+    (lambda ()
+      (setlocale locale-category locale)
+
+      ;; While we're at it, pass it to sub-processes.
+      (setenv (locale-category->string locale-category) locale)
+
+      (format (current-error-port) "using '~a' locale for category ~s~%"
+              locale (locale-category->string locale-category)))
+    (lambda args
+      ;; This is known to fail for instance in early bootstrap where locales
+      ;; are not available.
+      (format (current-error-port)
+              "warning: failed to install '~a' locale: ~a~%"
+              locale (strerror (system-error-errno args))))))
+
+(define* (unpack #:key source #:allow-other-keys)
+  "Unpack SOURCE in the working directory, and change directory within the
+source.  When SOURCE is a directory, copy it in a sub-directory of the current
+working directory."
+  (if (file-is-directory? source)
+      (begin
+        (mkdir "source")
+        (chdir "source")
+
+        ;; Preserve timestamps (set to the Epoch) on the copied tree so that
+        ;; things work deterministically.
+        (copy-recursively source "."
+                          #:keep-mtime? #t)
+        ;; Make the source checkout files writable, for convenience.
+        (for-each (lambda (f)
+                    (false-if-exception (make-file-writable f)))
+                  (find-files ".")))
+      (begin
+        (cond
+         ((string-suffix? ".zip" source)
+          (invoke "unzip" source))
+         ((tarball? source)
+          (invoke "tar" "xvf" source))
+         (else
+          (let ((name (strip-store-file-name source))
+                (command (compressor source)))
+            (copy-file source name)
+            (when command
+              (invoke command "--decompress" name)))))
+        ;; Attempt to change into child directory.
+        (and=> (first-subdirectory ".") chdir))))
+
+(define %bootstrap-scripts
+  ;; Typical names of Autotools "bootstrap" scripts.
+  '("bootstrap" "bootstrap.sh" "autogen.sh"))
+
+(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts)
+                    #:allow-other-keys)
+  "If the code uses Autotools and \"configure\" is missing, run
+\"autoreconf\".  Otherwise do nothing."
+  ;; Note: Run that right after 'unpack' so that the generated files are
+  ;; visible when the 'patch-source-shebangs' phase runs.
+  (define (script-exists? file)
+    (and (file-exists? file)
+         (not (file-is-directory? file))))
+
+  (if (not (script-exists? "configure"))
+
+      ;; First try one of the BOOTSTRAP-SCRIPTS.  If none exists, and it's
+      ;; clearly an Autoconf-based project, run 'autoreconf'.  Otherwise, do
+      ;; nothing (perhaps the user removed or overrode the 'configure' phase.)
+      (let ((script (find script-exists? bootstrap-scripts)))
+        ;; GNU packages often invoke the 'git-version-gen' script from
+        ;; 'configure.ac' so make sure it has a valid shebang.
+        (false-if-file-not-found
+         (patch-shebang "build-aux/git-version-gen"))
+
+        (if script
+            (let ((script (string-append "./" script)))
+              (setenv "NOCONFIGURE" "true")
+              (format #t "running '~a'~%" script)
+              (if (executable-file? script)
+                  (begin
+                    (patch-shebang script)
+                    (invoke script))
+                  (invoke "sh" script))
+              ;; Let's clean up after ourselves.
+              (unsetenv "NOCONFIGURE"))
+            (if (or (file-exists? "configure.ac")
+                    (file-exists? "configure.in"))
+                (invoke "autoreconf" "-vif")
+                (format #t "no 'configure.ac' or anything like that, \
+doing nothing~%"))))
+      (format #t "GNU build system bootstrapping not needed~%")))
+
+;; See <http://bugs.gnu.org/17840>.
+(define* (patch-usr-bin-file #:key native-inputs inputs
+                             (patch-/usr/bin/file? #t)
+                             #:allow-other-keys)
+  "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure'
+files found in the source tree.  This works around Libtool's Autoconf macros,
+which generates invocations of \"/usr/bin/file\" that are used to determine
+things like the ABI being used."
+  (when patch-/usr/bin/file?
+    (for-each (lambda (file)
+                (when (executable-file? file)
+                  (patch-/usr/bin/file file)))
+              (find-files "." "^configure$"))))
+
+(define* (patch-source-shebangs #:key source #:allow-other-keys)
+  "Patch shebangs in all source files; this includes non-executable
+files such as `.in' templates.  Most scripts honor $SHELL and
+$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
+`missing' script."
+  (for-each patch-shebang
+            (find-files "."
+                        (lambda (file stat)
+                          ;; Filter out symlinks.
+                          (eq? 'regular (stat:type stat)))
+                        #:stat lstat)))
+
+(define (patch-generated-file-shebangs . rest)
+  "Patch shebangs in generated files, including `SHELL' variables in
+makefiles."
+  ;; Patch executable regular files, some of which might have been generated
+  ;; by `configure'.
+  (for-each patch-shebang
+            (find-files "."
+                        (lambda (file stat)
+                          (and (eq? 'regular (stat:type stat))
+                               (not (zero? (logand (stat:mode stat) #o100)))))
+                        #:stat lstat))
+
+  ;; Patch `SHELL' in generated makefiles.
+  (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
+
+(define* (configure #:key build target native-inputs inputs outputs
+                    (configure-flags '()) out-of-source?
+                    #:allow-other-keys)
+  (define (package-name)
+    (let* ((out  (assoc-ref outputs "out"))
+           (base (basename out))
+           (dash (string-rindex base #\-)))
+      ;; XXX: We'd rather use `package-name->name+version' or similar.
+      (string-drop (if dash
+                       (substring base 0 dash)
+                       base)
+                   (+ 1 (string-index base #\-)))))
+
+  (let* ((prefix     (assoc-ref outputs "out"))
+         (bindir     (assoc-ref outputs "bin"))
+         (libdir     (assoc-ref outputs "lib"))
+         (includedir (assoc-ref outputs "include"))
+         (docdir     (assoc-ref outputs "doc"))
+         (bash       (or (and=> (assoc-ref (or native-inputs inputs) "bash")
+                                (cut string-append <> "/bin/bash"))
+                         "/bin/sh"))
+         (flags      `(,@(if target             ; cross building
+                             '("CC_FOR_BUILD=gcc")
+                             '())
+                       ,(string-append "CONFIG_SHELL=" bash)
+                       ,(string-append "SHELL=" bash)
+                       ,(string-append "--prefix=" prefix)
+                       "--enable-fast-install"    ; when using Libtool
+
+                       ;; Produce multiple outputs when specific output names
+                       ;; are recognized.
+                       ,@(if bindir
+                              (list (string-append "--bindir=" bindir "/bin"))
+                              '())
+                       ,@(if libdir
+                              (cons (string-append "--libdir=" libdir "/lib")
+                                    (if includedir
+                                        '()
+                                        (list
+                                         (string-append "--includedir="
+                                                        libdir "/include"))))
+                              '())
+                       ,@(if includedir
+                             (list (string-append "--includedir="
+                                                  includedir "/include"))
+                             '())
+                       ,@(if docdir
+                             (list (string-append "--docdir=" docdir
+                                                  "/share/doc/" (package-name)))
+                             '())
+                       ,@(if build
+                             (list (string-append "--build=" build))
+                             '())
+                       ,@(if target               ; cross building
+                             (list (string-append "--host=" target))
+                             '())
+                       ,@configure-flags))
+         (abs-srcdir (getcwd))
+         (srcdir     (if out-of-source?
+                         (string-append "../" (basename abs-srcdir))
+                         ".")))
+    (format #t "source directory: ~s (relative from build: ~s)~%"
+            abs-srcdir srcdir)
+    (if out-of-source?
+        (begin
+          (mkdir "../build")
+          (chdir "../build")))
+    (format #t "build directory: ~s~%" (getcwd))
+    (format #t "configure flags: ~s~%" flags)
+
+    ;; Use BASH to reduce reliance on /bin/sh since it may not always be
+    ;; reliable (see
+    ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
+    ;; for a summary of the situation.)
+    ;;
+    ;; Call `configure' with a relative path.  Otherwise, GCC's build system
+    ;; (for instance) records absolute source file names, which typically
+    ;; contain the hash part of the `.drv' file, leading to a reference leak.
+    (apply invoke bash
+           (string-append srcdir "/configure")
+           flags)))
+
+(define* (build #:key (make-flags '()) (parallel-build? #t)
+                #:allow-other-keys)
+  (apply invoke "make"
+         `(,@(if parallel-build?
+                 `("-j" ,(number->string (parallel-job-count)))
+                 '())
+           ,@make-flags)))
+
+(define* (dump-file-contents directory file-regexp
+                             #:optional (port (current-error-port)))
+  "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP."
+  (define (dump file)
+    (let ((prefix (string-append "\n--- " file " ")))
+      (display (if (< (string-length prefix) 78)
+                   (string-pad-right prefix 78 #\-)
+                   prefix)
+               port)
+      (display "\n\n" port)
+      (call-with-input-file file
+        (lambda (log)
+          (dump-port log port)))
+      (display "\n" port)))
+
+  (for-each dump (find-files directory file-regexp)))
+
+(define %test-suite-log-regexp
+  ;; Name of test suite log files as commonly found in GNU-based build systems
+  ;; and CMake.
+  "^(test-?suite\\.log|LastTestFailed\\.log)$")
+
+(define* (check #:key target (make-flags '()) (tests? (not target))
+                (test-target "check") (parallel-tests? #t)
+                (test-suite-log-regexp %test-suite-log-regexp)
+                #:allow-other-keys)
+  (if tests?
+      (guard (c ((invoke-error? c)
+                 ;; Dump the test suite log to facilitate debugging.
+                 (display "\nTest suite failed, dumping logs.\n"
+                          (current-error-port))
+                 (dump-file-contents "." test-suite-log-regexp)
+                 (raise c)))
+        (apply invoke "make" test-target
+               `(,@(if parallel-tests?
+                       `("-j" ,(number->string (parallel-job-count)))
+                       '())
+                 ,@make-flags)))
+      (format #t "test suite not run~%")))
+
+(define* (install #:key (make-flags '()) #:allow-other-keys)
+  (apply invoke "make" "install" make-flags))
+
+(define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
+                         #:allow-other-keys)
+  (define (list-of-files dir)
+    (map (cut string-append dir "/" <>)
+         (or (scandir dir (lambda (f)
+                            (let ((s (lstat (string-append dir "/" f))))
+                              (eq? 'regular (stat:type s)))))
+             '())))
+
+  (define bin-directories
+    (match-lambda
+     ((_ . dir)
+      (list (string-append dir "/bin")
+            (string-append dir "/sbin")
+            (string-append dir "/libexec")))))
+
+  (define output-bindirs
+    (append-map bin-directories outputs))
+
+  (define input-bindirs
+    ;; Shebangs should refer to binaries of the target system---i.e., from
+    ;; "inputs", not from "native-inputs".
+    (append-map bin-directories inputs))
+
+  (when patch-shebangs?
+    (let ((path (append output-bindirs input-bindirs)))
+      (for-each (lambda (dir)
+                  (let ((files (list-of-files dir)))
+                    (for-each (cut patch-shebang <> path) files)))
+                output-bindirs))))
+
+(define* (strip #:key target outputs (strip-binaries? #t)
+                (strip-command (if target
+                                   (string-append target "-strip")
+                                   "strip"))
+                (objcopy-command (if target
+                                     (string-append target "-objcopy")
+                                     "objcopy"))
+                (strip-flags '("--strip-unneeded"
+                               "--enable-deterministic-archives"))
+                (strip-directories '("lib" "lib64" "libexec"
+                                     "bin" "sbin"))
+                #:allow-other-keys)
+  (define debug-output
+    ;; If an output is called "debug", then that's where debugging information
+    ;; will be stored instead of being discarded.
+    (assoc-ref outputs "debug"))
+
+  (define debug-file-extension
+    ;; File name extension for debugging information.
+    ".debug")
+
+  (define (debug-file file)
+    ;; Return the name of the debug file for FILE, an absolute file name.
+    ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
+    ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
+    (string-append debug-output "/lib/debug/"
+                   file debug-file-extension))
+
+  (define (make-debug-file file)
+    ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
+    (let ((debug (debug-file file)))
+      (mkdir-p (dirname debug))
+      (copy-file file debug)
+      (invoke strip-command "--only-keep-debug" debug)
+      (chmod debug #o400)))
+
+  (define (add-debug-link file)
+    ;; Add a debug link in FILE (info "(binutils) strip").
+
+    ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
+    ;; link around so it can compute a CRC of that file (see the
+    ;; `bfd_fill_in_gnu_debuglink_section' function.)  No reference to
+    ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
+    ;; file.
+    (invoke objcopy-command "--enable-deterministic-archives"
+            (string-append "--add-gnu-debuglink="
+                           (debug-file file))
+            file))
+
+  (define (strip-dir dir)
+    (format #t "stripping binaries in ~s with ~s and flags ~s~%"
+            dir strip-command strip-flags)
+    (when debug-output
+      (format #t "debugging output written to ~s using ~s~%"
+              debug-output objcopy-command))
+
+    (for-each (lambda (file)
+                (when (or (elf-file? file) (ar-file? file))
+                  ;; If an error occurs while processing a file, issue a
+                  ;; warning and continue to the next file.
+                  (guard (c ((invoke-error? c)
+                             (format (current-error-port)
+                                     "warning: ~a: program ~s exited\
+~@[ with non-zero exit status ~a~]\
+~@[ terminated by signal ~a~]~%"
+                                     file
+                                     (invoke-error-program c)
+                                     (invoke-error-exit-status c)
+                                     (invoke-error-term-signal c))))
+                    (when debug-output
+                      (make-debug-file file))
+
+                    ;; Ensure the file is writable.
+                    (make-file-writable file)
+
+                    (apply invoke strip-command
+                           (append strip-flags (list file)))
+
+                    (when debug-output
+                      (add-debug-link file)))))
+              (find-files dir
+                          (lambda (file stat)
+                            ;; Ignore symlinks such as:
+                            ;; libfoo.so -> libfoo.so.0.0.
+                            (eq? 'regular (stat:type stat)))
+                          #:stat lstat)))
+
+  (when strip-binaries?
+    (for-each
+     strip-dir
+     (append-map (match-lambda
+                   ((_ . dir)
+                    (filter-map (lambda (d)
+                                  (let ((sub (string-append dir "/" d)))
+                                    (and (directory-exists? sub) sub)))
+                                strip-directories)))
+                 outputs))))
+
+(define* (validate-runpath #:key
+                           (validate-runpath? #t)
+                           (elf-directories '("lib" "lib64" "libexec"
+                                              "bin" "sbin"))
+                           outputs #:allow-other-keys)
+  "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
+ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
+
+Since the ELF parser needs to have a copy of files in memory, better run this
+phase after stripping."
+  (define (sub-directory parent)
+    (lambda (directory)
+      (let ((directory (string-append parent "/" directory)))
+        (and (directory-exists? directory) directory))))
+
+  (define (validate directory)
+    (define (file=? file1 file2)
+      (let ((st1 (stat file1))
+            (st2 (stat file2)))
+        (= (stat:ino st1) (stat:ino st2))))
+
+    ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
+    ;; duplicates.
+    (let ((files (delete-duplicates (find-files directory (lambda (file stat)
+                                                            (elf-file? file)))
+                                    file=?)))
+      (format (current-error-port)
+              "validating RUNPATH of ~a binaries in ~s...~%"
+              (length files) directory)
+      (every* validate-needed-in-runpath files)))
+
+  (if validate-runpath?
+      (let ((dirs (append-map (match-lambda
+                                (("debug" . _)
+                                 ;; The "debug" output is full of ELF files
+                                 ;; that are not worth checking.
+                                 '())
+                                ((name . output)
+                                 (filter-map (sub-directory output)
+                                             elf-directories)))
+                              outputs)))
+        (unless (every* validate dirs)
+          (error "RUNPATH validation failed")))
+      (format (current-error-port) "skipping RUNPATH validation~%")))
+
+(define* (validate-documentation-location #:key outputs
+                                          #:allow-other-keys)
+  "Documentation should go to 'share/info' and 'share/man', not just 'info/'
+and 'man/'.  This phase moves directories to the right place if needed."
+  (define (validate-sub-directory output sub-directory)
+    (let ((directory (string-append output "/" sub-directory)))
+      (when (directory-exists? directory)
+        (let ((target (string-append output "/share/" sub-directory)))
+          (format #t "moving '~a' to '~a'~%" directory target)
+          (mkdir-p (dirname target))
+          (rename-file directory target)))))
+
+  (define (validate-output output)
+    (for-each (cut validate-sub-directory output <>)
+              '("man" "info")))
+
+  (match outputs
+    (((names . directories) ...)
+     (for-each validate-output directories))))
+
+(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys)
+  "Reset embedded timestamps in gzip files found in OUTPUTS."
+  (define (process-directory directory)
+    (let ((files (find-files directory
+                             (lambda (file stat)
+                               (and (eq? 'regular (stat:type stat))
+                                    (or (string-suffix? ".gz" file)
+                                        (string-suffix? ".tgz" file))
+                                    (gzip-file? file)))
+                             #:stat lstat)))
+      ;; Ensure the files are writable.
+      (for-each make-file-writable files)
+      (for-each reset-gzip-timestamp files)))
+
+  (match outputs
+    (((names . directories) ...)
+     (for-each process-directory directories))))
+
+(define* (compress-documentation #:key outputs
+                                 (compress-documentation? #t)
+                                 (documentation-compressor "gzip")
+                                 (documentation-compressor-flags
+                                  '("--best" "--no-name"))
+                                 (compressed-documentation-extension ".gz")
+                                 #:allow-other-keys)
+  "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
+found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
+DOCUMENTATION-COMPRESSOR-FLAGS."
+  (define (retarget-symlink link)
+    (let ((target (readlink link)))
+      (delete-file link)
+      (symlink (string-append target compressed-documentation-extension)
+               (string-append link compressed-documentation-extension))))
+
+  (define (has-links? file)
+    ;; Return #t if FILE has hard links.
+    (> (stat:nlink (lstat file)) 1))
+
+  (define (points-to-symlink? symlink)
+    ;; Return #t if SYMLINK points to another symbolic link.
+    (let* ((target (readlink symlink))
+           (target-absolute (if (string-prefix? "/" target)
+                                target
+                                (string-append (dirname symlink)
+                                               "/" target))))
+      (catch 'system-error
+        (lambda ()
+          (symbolic-link? target-absolute))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              (begin
+                (format (current-error-port)
+                        "The symbolic link '~a' target is missing: '~a'\n"
+                        symlink target-absolute)
+                #f)
+              (apply throw args))))))
+
+  (define (maybe-compress-directory directory regexp)
+    (when (directory-exists? directory)
+      (match (find-files directory regexp)
+        (()                                     ;nothing to compress
+         #t)
+        ((files ...)                            ;one or more files
+         (format #t
+                 "compressing documentation in '~a' with ~s and flags ~s~%"
+                 directory documentation-compressor
+                 documentation-compressor-flags)
+         (call-with-values
+             (lambda ()
+               (partition symbolic-link? files))
+           (lambda (symlinks regular-files)
+             ;; Compress the non-symlink files, and adjust symlinks to refer
+             ;; to the compressed files.  Leave files that have hard links
+             ;; unchanged ('gzip' would refuse to compress them anyway.)
+             ;; Also, do not retarget symbolic links pointing to other
+             ;; symbolic links, since these are not compressed.
+             (for-each retarget-symlink
+                       (filter (lambda (symlink)
+                                 (and (not (points-to-symlink? symlink))
+                                      (string-match regexp symlink)))
+                               symlinks))
+             (apply invoke documentation-compressor
+                    (append documentation-compressor-flags
+                            (remove has-links? regular-files)))))))))
+
+  (define (maybe-compress output)
+    (maybe-compress-directory (string-append output "/share/man")
+                              "\\.[0-9]+$")
+    (maybe-compress-directory (string-append output "/share/info")
+                              "\\.info(-[0-9]+)?$"))
+
+  (if compress-documentation?
+      (match outputs
+        (((names . directories) ...)
+         (for-each maybe-compress directories)))
+      (format #t "not compressing documentation~%")))
+
+(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
+  "Delete any 'share/info/dir' file from OUTPUTS."
+  (for-each (match-lambda
+          ((output . directory)
+           (let ((info-dir-file (string-append directory "/share/info/dir")))
+             (when (file-exists? info-dir-file)
+               (delete-file info-dir-file)))))
+            outputs))
+
+
+(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
+  "Replace any references to executables in '.desktop' files with their
+absolute file names."
+  (define bin-directories
+    (append-map (match-lambda
+                  ((_ . directory)
+                   (list (string-append directory "/bin")
+                         (string-append directory "/sbin"))))
+                outputs))
+
+  (define (which program)
+    (or (search-path bin-directories program)
+        (begin
+          (format (current-error-port)
+                  "warning: '.desktop' file refers to '~a', \
+which cannot be found~%"
+                  program)
+          program)))
+
+  (for-each (match-lambda
+              ((_ . directory)
+               (let ((applications (string-append directory
+                                                  "/share/applications")))
+                 (when (directory-exists? applications)
+                   (let ((files (find-files applications "\\.desktop$")))
+                     (format #t "adjusting ~a '.desktop' files in ~s~%"
+                             (length files) applications)
+
+                     ;; '.desktop' files contain translations and are always
+                     ;; UTF-8-encoded.
+                     (with-fluids ((%default-port-encoding "UTF-8"))
+                       (substitute* files
+                         (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+                          (string-append "Exec=" (which binary) rest))
+                         (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+                          (string-append "TryExec="
+                                         (which binary) rest)))))))))
+            outputs))
+
+(define* (make-dynamic-linker-cache #:key outputs
+                                    (make-dynamic-linker-cache? #t)
+                                    #:allow-other-keys)
+  "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the
+OUTPUTS.  This reduces application startup time by avoiding the 'stat' storm
+that traversing all the RUNPATH entries entails."
+  (define (make-cache-for-output directory)
+    (define bin-directories
+      (filter-map (lambda (sub-directory)
+                    (let ((directory (string-append directory "/"
+                                                    sub-directory)))
+                      (and (directory-exists? directory)
+                           directory)))
+                  '("bin" "sbin" "libexec")))
+
+    (define programs
+      ;; Programs that can benefit from the ld.so cache.
+      (append-map (lambda (directory)
+                    (if (directory-exists? directory)
+                        (find-files directory
+                                    (lambda (file stat)
+                                      (and (executable-file? file)
+                                           (elf-file? file))))
+                        '()))
+                  bin-directories))
+
+    (define library-path
+      ;; Directories containing libraries that PROGRAMS depend on,
+      ;; recursively.
+      (delete-duplicates
+       (append-map (lambda (program)
+                     (map dirname (file-needed/recursive program)))
+                   programs)))
+
+    (define cache-file
+      (string-append directory "/etc/ld.so.cache"))
+
+    (define ld.so.conf
+      (string-append (or (getenv "TMPDIR") "/tmp")
+                     "/ld.so.conf"))
+
+    (unless (null? library-path)
+      (mkdir-p (dirname cache-file))
+      (guard (c ((invoke-error? c)
+                 ;; Do not treat 'ldconfig' failure as an error.
+                 (format (current-error-port)
+                         "warning: 'ldconfig' failed:~%")
+                 (report-invoke-error c (current-error-port))))
+        ;; Create a config file to tell 'ldconfig' where to look for the
+        ;; libraries that PROGRAMS need.
+        (call-with-output-file ld.so.conf
+          (lambda (port)
+            (for-each (lambda (directory)
+                        (display directory port)
+                        (newline port))
+                      library-path)))
+
+        (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file)
+        (format #t "created '~a' from ~a library search path entries~%"
+                cache-file (length library-path)))))
+
+  (if make-dynamic-linker-cache?
+      (match outputs
+        (((_ . directories) ...)
+         (for-each make-cache-for-output directories)))
+      (format #t "ld.so cache not built~%")))
+
+(define %license-file-regexp
+  ;; Regexp matching license files.
+  "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
+
+(define* (install-license-files #:key outputs
+                                (license-file-regexp %license-file-regexp)
+                                out-of-source?
+                                #:allow-other-keys)
+  "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
+  (define (find-source-directory package)
+    ;; For an out-of-source build, guess the source directory location
+    ;; relative to the current directory.  Return #f on failure.
+    (match (scandir ".."
+                    (lambda (file)
+                      (and (not (member file '("." ".." "build")))
+                           (file-is-directory?
+                            (string-append "../" file)))))
+      (()                                         ;hmm, no source
+       #f)
+      ((source)                                   ;only one other file
+       (string-append "../" source))
+      ((directories ...)                          ;pick the most likely one
+       ;; This happens for example with libstdc++, which lives within the GCC
+       ;; source tree.
+       (any (lambda (directory)
+              (and (string-prefix? package directory)
+                   (string-append "../" directory)))
+            directories))))
+
+  (define (copy-to-directories directories sub-directory)
+    (lambda (file)
+      (for-each (if (file-is-directory? file)
+                    (cut copy-recursively file <>)
+                    (cut install-file file <>))
+                (map (cut string-append <> "/" sub-directory)
+                     directories))))
+
+  (let* ((regexp    (make-regexp license-file-regexp))
+         (out       (or (assoc-ref outputs "out")
+                        (match outputs
+                          (((_ . output) _ ...)
+                           output))))
+         (package   (strip-store-file-name out))
+         (outputs   (match outputs
+                      (((_ . outputs) ...)
+                       outputs)))
+         (source    (if out-of-source?
+                        (find-source-directory
+                         (package-name->name+version package))
+                        "."))
+         (files     (and source
+                         (scandir source
+                                  (lambda (file)
+                                    (regexp-exec regexp file))))))
+    (if files
+        (begin
+          (format #t "installing ~a license files from '~a'~%"
+                  (length files) source)
+          (for-each (copy-to-directories outputs
+                                         (string-append "share/doc/"
+                                                        package))
+                    (map (cut string-append source "/" <>) files)))
+        (format (current-error-port)
+                "failed to find license files~%"))))
+
+(define %standard-phases
+  ;; Standard build phases, as a list of symbol/procedure pairs.
+  (let-syntax ((phases (syntax-rules ()
+                         ((_ p ...) `((p . ,p) ...)))))
+    (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
+            bootstrap
+            patch-usr-bin-file
+            patch-source-shebangs configure patch-generated-file-shebangs
+            build check install
+            patch-shebangs strip
+            validate-runpath
+            validate-documentation-location
+            delete-info-dir-file
+            patch-dot-desktop-files
+            make-dynamic-linker-cache
+            install-license-files
+            reset-gzip-timestamps
+            compress-documentation)))
+
+
+(define* (gnu-build2 #:key (source #f) (outputs #f) (inputs #f)
+                     (phases %standard-phases)
+                     #:allow-other-keys
+                     #:rest args)
+  "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
+in order.  Return #t if all the PHASES succeeded, #f otherwise."
+  (define (elapsed-time end start)
+    (let ((diff (time-difference end start)))
+      (+ (time-second diff)
+         (/ (time-nanosecond diff) 1e9))))
+
+  (setvbuf (current-output-port) 'line)
+  (setvbuf (current-error-port) 'line)
+
+  ;; Encoding/decoding errors shouldn't be silent.
+  (fluid-set! %default-port-conversion-strategy 'error)
+
+  (guard (c ((invoke-error? c)
+             (report-invoke-error c)
+             (exit 1)))
+    ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
+    ;; PHASES can pick the keyword arguments it's interested in.
+    (for-each (match-lambda
+                ((name . proc)
+                 (let ((start (current-time time-monotonic)))
+                   (define (end-of-phase success?)
+                     (let ((end (current-time time-monotonic)))
+                       (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
+                               name success?
+                               (elapsed-time end start))
+
+                       ;; Dump the environment variables as a shell script,
+                       ;; for handy debugging.
+                       (system "export > $NIX_BUILD_TOP/environment-variables")))
+
+                   (format #t "starting phase `~a'~%" name)
+                   (with-throw-handler #t
+                     (lambda ()
+                       (apply proc args)
+                       (end-of-phase #t))
+                     (lambda args
+                       ;; This handler executes before the stack is unwound.
+                       ;; The exception is automatically re-thrown from here,
+                       ;; and we should get a proper backtrace.
+                       (format (current-error-port)
+                               "error: in phase '~a': uncaught exception:
+~{~s ~}~%" name args)
+                       (end-of-phase #f))))))
+              phases)))

base-commit: e2bcd41ce35b051f311e36dfd104d36ce1145f8b
prerequisite-patch-id: 77c51f63cfaba6cafe4e7125f50077d6dc5ca24a
prerequisite-patch-id: 776778c03bce9b7ad3ab94a120f42b764c00fcae
prerequisite-patch-id: 4910d08bdc27384d76030b6ac491ad2c2ed0957f
prerequisite-patch-id: 2de8762a6381a93682d0fe4c893962b9803362b0
prerequisite-patch-id: b9b6f21a2db3f7a5ef82bb11ed23f69749cc6b3d
-- 
2.38.1