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

;;;
;;; pkg-name
;;;

(define pkg-name-prefix
  "erlang-")

;; Pattern that an Erlang Guix package is expected to match.
(define pkg-name-prefix-re
  (format #f "^~a(.*)" pkg-name-prefix))

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

(define (pkg-name? name)
  "Test if NAME is the name of an Erlang Guix package.

Example: erlang-ssl-verify-fun 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 to NAME.

Example: if an Erlang Guix package name is \"erlang-ssl-verify-fun\" and its
version is 1.2.3, then the associated library directory name is:
\"ssl_verify_fun-1.2.3\".

See:
  - \"Library directory\" description: https://www.erlang.org/doc/man/code#code-path
"
  (string-append (string-replace-substring (pkg-name->suffix name) "-" "_")
                 (if (string= version "") ""
                     (string-append "-" version))))

;;;
;;; hexpm
;;;

;; 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-prefix-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)))

;;
;; utils
;;

(define (utils-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 (utils-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 utils-imported-modules
  `((guix build rebar-build-system)
    ,@%gnu-build-system-modules))

;;
;; source
;;
;; If s is a Source, then s has the form (list <name> <source>) where:
;;   <name> is a string representing the name of a library directory.
;;   <origin> is an origin (see: guix/packages.scm) which represents the
;;   source code associated to this library.
;;

(define source->name
  car)
(define source->origin
  cadr)

;;
;; input
;;
;; If i is an Input, then i has the form (list <name> <package>) where:
;;   <name> is a string representing the name of a package.
;;   <package> is a package with the associated name.

(define input->name
  car)
(define input->package
  cadr)

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

;;
;; rebar
;;

(define* (rebar-build name
                      inputs
                      #:key guile
                      source
                      ;; XXX: these are useless.
                      (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 utils-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* (rebar-lower name
                      #:key (erlang (utils-erlang-default))
                      inputs
                      native-inputs
                      outputs
                      (rebar (utils-rebar-default))
                      source
                      system
                      target
                      #:allow-other-keys #:rest arguments)
  "Return a bag for NAME from the given arguments."

  (let* ((erlang-packages ;List of Erlang packages.
          (filter (lambda (input)
                    (pkg-name? (input->name input)))
                  (append inputs native-inputs)))

         (erlang-sources (map (lambda (input)
                                (input->source input)) 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 rebar-lower)))

;;;
;;; Exports
;;;

(define hexpm-uri
  hexpm->uri)

(define hexpm-package-url
  hexpm-tarballs)

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