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 ;;; Copyright © 2020 Hartmut Goebel +;;; Copyright © 2023 Pierre-Henry Fröhring ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,20 +19,120 @@ ;;; along with GNU Guix. If not, see . (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