Package: guix-patches;
Reported by: Pierre-Henry Fröhring <phfrohring <at> deeplinks.com>
Date: Sat, 28 Oct 2023 20:21:02 UTC
Severity: normal
Tags: patch
Done: Liliana Marie Prikler <liliana.prikler <at> gmail.com>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Pierre-Henry Fröhring <phfrohring <at> deeplinks.com> To: 66801 <at> debbugs.gnu.org Cc: Pierre-Henry Fröhring <phfrohring <at> deeplinks.com> Subject: [bug#66801] [PATCH 1/5] guix: build-system: rebar: build Erlang packages with dependencies. Date: Wed, 8 Nov 2023 10:22:35 +0100
Change-Id: Ie221d47fd1c9a766c2e2cdf76460ddfdf65e090d
---
guix/build-system/rebar.scm | 223 ++++++++++++++++++++++--------
guix/build/rebar-build-system.scm | 43 +++---
2 files changed, 189 insertions(+), 77 deletions(-)
diff --git a/guix/build-system/rebar.scm b/guix/build-system/rebar.scm
index de1294ec..cdff85a6 100644
--- a/guix/build-system/rebar.scm
+++ b/guix/build-system/rebar.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado <at> elephly.net>
;;; Copyright © 2020 Hartmut Goebel <h.goebel <at> crazy-compilers.com>
+;;; Copyright © 2023 Pierre-Henry Fröhring <phfrohring <at> deeplinks.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,20 +19,120 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build-system rebar)
- #:use-module (guix store)
- #:use-module (guix utils)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix build-system)
#:use-module (guix gexp)
- #:use-module (guix packages)
#:use-module (guix monads)
+ #:use-module (guix packages)
#:use-module (guix search-paths)
- #:use-module (guix build-system)
- #:use-module (guix build-system gnu)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:export (hexpm-uri
hexpm-package-url
%rebar-build-system-modules
rebar-build
rebar-build-system))
+
+;;;
+;;; Utils
+;;;
+
+(define (flatten lst) (fold append '() lst))
+
+
+;;;
+;;; Packages
+;;;
+
+(define %erlang-package-prefix "erlang-")
+
+(define (erlang-package-name? name)
+ "Indicates if NAME is an Erlang package name.
+If a package name starts with %erlang-package-prefix, then it is an Erlang package name.
+An Erlang package name must start with %erlang-package-prefix."
+ (string-prefix? %erlang-package-prefix name))
+
+(define (hexpm-name pkg-name)
+ "Given a package name PKG-NAME, returns the corresponding hex.pm package name."
+ (let ((suffix (string-drop pkg-name (string-length %erlang-package-prefix))))
+ (string-replace-substring suffix "-" "_")))
+
+(define (all-transitive-inputs pkg pred)
+ "Given a package PKG and a predicate PRED, return all transitive inputs of PKG
+that match the predicate PRED."
+ (delete-duplicates
+ (append
+ (filter pred (package-transitive-inputs pkg))
+ (filter pred (package-transitive-native-inputs pkg))
+ (filter pred (package-transitive-propagated-inputs pkg)))
+ input=?))
+
+
+;;;
+;;; Input
+;;;
+
+(define (input-mk name package)
+ "Build an Input."
+ (list name package))
+
+(define (input->name input)
+ "Return the name of INPUT."
+ (car input))
+
+(define (input->package input)
+ "Return the package of INPUT."
+ (cadr input))
+
+(define (input=? i1 i2)
+ "Test whether Inputs I1 and I2 are equal."
+ (string=? (input->name i1) (input->name i2)))
+
+(define (erlang-input? input)
+ "Test whether INPUT is an Erlang Input."
+ (erlang-package-name? (input->name input)))
+
+(define (input->all-inputs input pred)
+ "Return the list of implicit satisfying PRED Inputs associated to INPUT, including INPUT."
+ (cons input (all-transitive-inputs (input->package input) pred)))
+
+(define (inputs->all-erlang-inputs erlang-inputs)
+ "Return a list of implicit Erlang Inputs associated to INPUT, including INPUT."
+ (let ((all-inputs (flatten (map (cut input->all-inputs <> erlang-package-name?) erlang-inputs))))
+ (delete-duplicates all-inputs input=?)))
+
+
+;;;
+;;; Source
+;;;
+
+(define (source-mk name origin)
+ "Build a source.
+NAME is an hex.pm package name.
+ORIGIN is an Origin."
+ (list name origin))
+
+(define (source->name source)
+ "Return the name of SOURCE."
+ (car source))
+
+(define (source->origin source)
+ "Return the origin of SOURCE."
+ (cadr source))
+
+(define (source=? s1 s2)
+ "Test whether Sources S1 and S2 are equal."
+ (string=? (source->name s1) (source->name s2)))
+
+(define (input->source input)
+ "Given an Input INPUT, return its associated Source."
+ (source-mk (hexpm-name (input->name input))
+ (package-source (input->package input))))
+
+
;;;
;;; Definitions for the hex.pm repository,
;;;
@@ -44,10 +145,11 @@ (define %hexpm-repo-url
(define hexpm-package-url
(string-append (%hexpm-repo-url) "/tarballs/"))
-(define (hexpm-uri name version)
+(define (hexpm-uri pkg-name version)
"Return a URI string for the package hosted at hex.pm corresponding to NAME
and VERSION."
- (string-append hexpm-package-url name "-" version ".tar"))
+ (let ((name (if (erlang-package-name? pkg-name) (hexpm-name pkg-name) pkg-name)))
+ (string-append hexpm-package-url name "-" version ".tar")))
;;
;; Standard build procedure for Erlang packages using Rebar.
@@ -78,42 +180,50 @@ (define* (lower name
#:rest arguments)
"Return a bag for NAME from the given arguments."
(define private-keywords
- '(#:target #:rebar #:erlang #:inputs #:native-inputs))
-
- (and (not target) ;XXX: no cross-compilation
- (bag
- (name name)
- (system system)
- (host-inputs `(,@(if source
- `(("source" ,source))
- '())
- ,@inputs))
- (build-inputs `(("rebar" ,rebar)
- ("erlang" ,erlang) ;; for escriptize
- ,@native-inputs
- ;; Keep the standard inputs of 'gnu-build-system'.
- ,@(standard-packages)))
- (outputs outputs)
- (build rebar-build)
- (arguments (strip-keyword-arguments private-keywords arguments)))))
+ '(#:target #:rebar #:erlang #:inputs #:native-inputs #:erlang-sources))
+
+ (let* ((inputs-all (append inputs native-inputs))
+ (erlang-inputs (filter erlang-input? inputs-all))
+ (all-erlang-inputs (inputs->all-erlang-inputs erlang-inputs))
+ (all-erlang-sources (map input->source all-erlang-inputs)))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs))
+ (build-inputs `(("rebar" ,rebar)
+ ("erlang" ,erlang) ;; for escriptize
+ ,@inputs
+ ,@native-inputs
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (outputs outputs)
+ (build rebar-build)
+ (arguments (append (list #:erlang-sources all-erlang-sources)
+ (strip-keyword-arguments private-keywords arguments)))))))
(define* (rebar-build name inputs
- #:key
- guile source
- (rebar-flags ''("skip_deps=true" "-vv"))
- (tests? #t)
- (test-target "eunit")
- ;; TODO: install-name ; default: based on guix package name
- (install-profile "default")
- (phases '(@ (guix build rebar-build-system)
- %standard-phases))
- (outputs '("out"))
- (search-paths '())
- (native-search-paths '())
- (system (%current-system))
- (imported-modules %rebar-build-system-modules)
- (modules '((guix build rebar-build-system)
- (guix build utils))))
+ #:key
+ guile source
+ (rebar-flags ''("skip_deps=true" "-vv"))
+ (tests? #t)
+ (test-target "eunit")
+ ;; TODO: install-name ; default: based on guix package name
+ (install-profile "default")
+ (phases '(@ (guix build rebar-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+ (erlang-sources '())
+ (system (%current-system))
+ (imported-modules %rebar-build-system-modules)
+ (modules '((guix build rebar-build-system)
+ (guix build utils))))
"Build SOURCE with INPUTS."
(define builder
@@ -123,21 +233,22 @@ (define* (rebar-build name inputs
#$(with-build-variables inputs outputs
#~(rebar-build #:source #+source
- #:system #$system
- #:name #$name
- #:rebar-flags #$rebar-flags
- #:tests? #$tests?
- #:test-target #$test-target
- ;; TODO: #:install-name #$install-name
- #:install-profile #$install-profile
- #:phases #$(if (pair? phases)
- (sexp->gexp phases)
- phases)
- #:outputs %outputs
- #:search-paths '#$(sexp->gexp
- (map search-path-specification->sexp
- search-paths))
- #:inputs %build-inputs)))))
+ #:system #$system
+ #:name #$name
+ #:rebar-flags #$rebar-flags
+ #:tests? #$tests?
+ #:test-target #$test-target
+ ;; TODO: #:install-name #$install-name
+ #:install-profile #$install-profile
+ #:phases #$(if (pair? phases)
+ (sexp->gexp phases)
+ phases)
+ #:outputs %outputs
+ #:search-paths '#$(sexp->gexp
+ (map search-path-specification->sexp
+ search-paths))
+ #:inputs %build-inputs
+ #:erlang-sources '#$erlang-sources)))))
(mlet %store-monad ((guile (package->derivation (or guile (default-guile))
system #:graft? #f)))
diff --git a/guix/build/rebar-build-system.scm b/guix/build/rebar-build-system.scm
index fb664228..286e4e1a 100644
--- a/guix/build/rebar-build-system.scm
+++ b/guix/build/rebar-build-system.scm
@@ -28,6 +28,13 @@ (define-module (guix build rebar-build-system)
#:export (rebar-build
%standard-phases))
+;;
+;; Utils
+;;
+
+(define sep file-name-separator-string)
+
+
;;
;; Builder-side code of the standard build procedure for Erlang packages using
;; rebar3.
@@ -37,27 +44,20 @@ (define-module (guix build rebar-build-system)
(define %erlang-libdir "/lib/erlang/lib")
-(define* (erlang-depends #:key inputs #:allow-other-keys)
- (define input-directories
- (match inputs
- (((_ . dir) ...)
- dir)))
- (mkdir-p "_checkouts")
-
- (for-each
- (lambda (input-dir)
- (let ((elibdir (string-append input-dir %erlang-libdir)))
- (when (directory-exists? elibdir)
- (for-each
- (lambda (dirname)
- (let ((dest (string-append elibdir "/" dirname))
- (link (string-append "_checkouts/" dirname)))
- (when (not (file-exists? link))
- ;; RETHINK: Maybe better copy and make writable to avoid some
- ;; error messages e.g. when using with rebar3-git-vsn.
- (symlink dest link))))
- (list-directories elibdir)))))
- input-directories))
+(define (configure-environment . _)
+ (setenv "REBAR_CACHE_DIR" (getcwd)))
+
+(define* (erlang-depends #:key erlang-sources #:allow-other-keys)
+ (let ((checkouts "_checkouts"))
+ (mkdir-p checkouts)
+ (for-each (lambda (source)
+ (match source
+ ((name archive)
+ (let ((libdir (string-append checkouts sep name)))
+ (mkdir-p libdir)
+ (with-directory-excursion libdir
+ (unpack #:source archive))))))
+ erlang-sources)))
(define* (unpack #:key source #:allow-other-keys)
"Unpack SOURCE in the working directory, and change directory within the
@@ -134,6 +134,7 @@ (define* (install #:key name outputs
(define %standard-phases
(modify-phases gnu:%standard-phases
(replace 'unpack unpack)
+ (add-after 'unpack 'configure-environment configure-environment)
(delete 'bootstrap)
(delete 'configure)
(add-before 'build 'erlang-depends erlang-depends)
--
2.41.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.