;;; 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.
;;;
;;; 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 rebar)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:export (hexpm-uri hexpm-package-url %rebar-build-system-modules
                      rebar-build rebar-build-system))

;; Source
;;   A « Source » reprensents the source code to a library directory. It is
;;   defined as (list <name> <origin>) where: <name> is a string representing
;;   the name of a library directory and <origin> is an origin as defined
;;   (guix packages).


;; Pattern that an Erlang Guix package name is expected to match.
(define pkg-name-re "^erlang-(.*)")

(define (pkg-name->match name)
  "Return the match object from NAME if NAME starts with pkg-name-prefix."
  (string-match pkg-name-re name))

(define (pkg-name? name)
  "Test if NAME is the name of an Erlang Guix package."
  (or (pkg-name->match name) #f))

(define (pkg-name->suffix name)
  "Return the suffix of the name of an Erlang Guix package."
  (regexp-substitute #f (pkg-name->match name) 1))

(define* (pkg-name->library-directory-name name #:key (version ""))
  "Return the name of the library directory associated with the Erlang Guix package name NAME."
  (string-append (string-replace-substring (pkg-name->suffix name) "-" "_")
                 (if (string= version "") "" (string-append "-" version))))

;; See: https://github.com/hexpm/specifications/blob/master/endpoints.md
(define hexpm (make-parameter "https://repo.hex.pm"))

(define hexpm-tarballs (string-append (hexpm) "/tarballs/"))

(define (hexpm-uri name version)
  "Return a URI string for the package hosted at hex.pm corresponding to NAME
and VERSION.

XXX: should a warning be emitted?
If NAME is not an Erlang Guix package name, then emit a warning. The download
will fail if it is not correct anyway."

  (define (warn-about name)
    (format #t "AssertionWarning 4dcbff27
  Assertion: re matches name.
    re = ~a
    name = ~a
" pkg-name-re name)

    name)

  (define (name->archive-name name)
    (if (pkg-name? name)
        (string-append (pkg-name->library-directory-name name #:version version) ".tar")
        (string-append (warn-about name) "-" version ".tar")))

  (string-append hexpm-tarballs (name->archive-name name)))

(define (rebar-default)
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((erlang-mod (resolve-interface '(gnu packages erlang))))
    (module-ref erlang-mod 'rebar3)))

(define (erlang-default)
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((erlang-mod (resolve-interface '(gnu packages erlang))))
    (module-ref erlang-mod 'erlang)))

(define imported-modules
  `((guix build rebar-build-system)
    ,@%gnu-build-system-modules))

(define (input->source input)
  "Return a Source associated to the Input INPUT."
  (match input
    ((name package)
     (list (pkg-name->library-directory-name name)
           (package-source package)))))

(define* (rebar-build name
                      inputs
                      #:key
                      guile
                      source
                      (rebar-flags ''())
                      (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 imported-modules)
                      (modules '((guix build rebar-build-system)
                                 (guix build utils)))
                      (sources-erlang '()))
  "Build SOURCE with INPUTS."

  (define builder
    (with-imported-modules imported-modules
      #~(begin
          (use-modules #$@(sexp->gexp modules))

          #$(with-build-variables inputs outputs

              #~(rebar-build #:source #+source
                             #:sources-erlang '#$sources-erlang
                             #: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)))))

  (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
                      #:guile-for-build guile)))

(define* (lower name
                      #:key
                      (erlang (erlang-default))
                      inputs
                      native-inputs
                      outputs
                      (rebar (rebar-default))
                      source
                      system
                      target
                      #:allow-other-keys #:rest arguments)
  "Return a bag for NAME from the given arguments."

  (let* ((erlang-packages
          (filter (lambda (input)
                    (match input
                      ((name _) (pkg-name? name))))
                  (append inputs native-inputs)))

         (erlang-sources (map input->source erlang-packages)))

    (define private-keywords
      '(#:target #:rebar #:erlang #:inputs #:native-inputs #:sources-erlang))

    (and (not target) ;XXX: no cross-compilation
         (bag (name name)
              (system system)
              (host-inputs inputs)
              (build-inputs `(,@(standard-packages)
                              ("erlang" ,erlang)
                              ("rebar" ,rebar)
                              ,@inputs
                              ,@native-inputs))
              (outputs outputs)
              (build rebar-build)
              (arguments (append (list #:sources-erlang erlang-sources)
                                 (strip-keyword-arguments private-keywords
                                                          arguments)))))))

(define rebar-build-system
  (build-system (name 'rebar)
                (description "The standard Rebar build system")
                (lower lower)))


;;;
;;; Exports
;;;

(define hexpm-package-url hexpm-tarballs)

(define %rebar-build-system-modules imported-modules)


;;; rebar.scm ends here