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

[Liliana Marie Prikler]

Am Mittwoch, dem 08.11.2023 um 10:22 +0100 schrieb Pierre-Henry
Fröhring:
> Change-Id: Ie221d47fd1c9a766c2e2cdf76460ddfdf65e090d
> ---
Missing the ChangeLog :)

Also, don't forget to add me to CC so that I can see the changes more
easily.

>  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))
You use this procedure once and you can probably replace it with
append-map from SRFI-1.

> +;;;
> +;;; 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=?))
We already have package-direct-inputs.  Instead of matching labels, you
might want to match package names instead anyway.

> +
> +;;;
> +;;; 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))
You shouldn't define such destructuring procedures.  Use (ice-9 match)
where needed.

> +(define (input=? i1 i2)
> +  "Test whether Inputs I1 and I2 are equal."
> +  (string=? (input->name i1) (input->name i2)))
Yeah, don't compare labels.

> +(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=?)))
The name, arguments, and docstring of this function do not match in any
way.  Consider expressing yourself in terms of known Guile functions.  

  (define (transitive-erlang-inputs inputs)
    (define (erlang-inputs inputs)
      (filter-map
        (match-lambda ((name package . output)
                       (and (erlang-package-name?) 
                            (cons* name package output))))
        inputs))
    (delete-duplicates
      (append-map erlang-inputs 
                  (append-map
                   package-transitive-inputs
                   (map cadr inputs)))))

Note that there's almost certainly a smarter way than nesting two
append-maps, but am currently too lazy to look that up.

> +
> +;;;
> +;;; 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))))
Again, use ice-9 match instead of manually defining all those
destructuring procedures.

> +
>  ;;;
>  ;;; 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)))
Instead of let-binding these, you might want to define a procedure
(erlang-sources inputs native-inputs) and then use that for #:erlang-
sources.

> +    (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)
How about no?

> +
>  ;;
>  ;; 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)))
How about simply naming this configure, so that you can use replace
instead of add-after + delete below?

> +(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)))
Alternatively add a slash (/) to checkouts ;)
> +                     (mkdir-p libdir)
> +                     (with-directory-excursion libdir
> +                       (unpack #:source archive))))))
> +              erlang-sources)))
This loses the previous erlang-depends logic, which unpackaged the
already compiled packages.  I really don't think we should have erlang
be yet another rust that heats up the planet compiling leftpad over and
over again.  Can we somehow have that cake?

>  (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)

Cheers