[bug#66801] [PATCH 1/5] guix: build-system: rebar: build Erlang packages with dependencies.

["Pierre-Henry Fröhring" <phfrohring@deeplinks.com>]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=yes, Size: 13264 bytes --]

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@elephly.net>
 ;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Pierre-Henry Fröhring <phfrohring@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