;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;; Copyright © 2020, 2022 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 rebar-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build utils) #:hide (delete))
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 string-fun)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (rebar-build %standard-phases))

;;
;; Builder-side code of the standard build procedure for Erlang packages using
;; rebar3.
;;
;; Library directory
;;   A « library directory » is a directory where Erlang searches for compiled
;;   code. Its name should look like: `a_name-1.2.3' where the suffix `-1.2.3'
;;   is optional. See: https://www.erlang.org/doc/man/code#code-path.
;;
;; Package name
;;   A « package name » is the value of the name field of a package
;;   definition. It looks like: `prefix-a-name-1.2.3'. See:
;;   https://guix.gnu.org/manual/en/html_node/Package-Naming.html
;;
;; Profile
;;   For Rebar3, a « profile » is a name associated to a set of configuration
;;   settings overriding or complementing the regular configuration. See:
;;   https://rebar3.org/docs/configuration/profiles
;;
;; Source
;;   A « source » represents the source code associated to a Guix package as
;;   defined by its `source' field. Here, the data sctructure used to
;;   represent a source has the form `(list name path)' where `name' is a
;;   library directory name and `path' is the store path where to find the
;;   source code.
;;
;; Checkout
;;   A « checkout » is a locally defined dependency related to a directory
;;   managed by rebar.  See:
;;   https://rebar3.org/docs/configuration/dependencies/#checkout-dependencies

(define sep "/")

;; Where Erlang libraries are installed relative to a package path in the store.
(define lib-erlang-lib "lib/erlang/lib")

(define (list-directories directory)
  "Return file names of the sub-directory of DIRECTORY."
  (scandir directory
           (lambda (file)
             (and (not (member file '("." "..")))
                  (file-is-directory? (string-append directory sep file))))))

(define* (pkg-name->libdir-name name)
  "Return the library name deduced from the Erlang package name NAME."
  (let* ((suffix (regexp-substitute #f (string-match "^erlang-(.*)" name) 1))
         (elements (string-split suffix #\-)))
    (string-append (string-join (drop-right elements 1) "_") "-" (last elements))))

(define (libdir-name->prefix name)
  "Return the prefix of a library directory name NAME."
  (car (string-split name #\-)))

(define (rebar-build-dir profile)
  "Return the path where rebar builds libraries given the profile PROFILE."
  (format #f "_build/~a/lib" profile))

(define* (pkg-name->build-dir name #:key (profile "default"))
  "Return the path of library directory where rebar3 builds code of an Erlang package named NAME given the profile PROFILE."
  (string-append (rebar-build-dir profile) sep (libdir-name->prefix (pkg-name->libdir-name name))))

(define* (unpack #:key source #:allow-other-keys)
  (if (file-is-directory? source)
      ;; If source is a checkout:
      (begin
        ;; Preserve timestamps (set to the Epoch) on the copied tree so that
        ;; things work deterministically.
        (copy-recursively source "." #:keep-mtime? #t)
        ;; Make the source checkout files writable, for convenience.
        (for-each (lambda (f)
                    (false-if-exception (make-file-writable f)))
                  (find-files ".")))

      ;; If source is an hex.pm archive:
      (begin
        (invoke "tar" "xvf" source)
        (invoke "tar" "xvf" "contents.tar.gz")

        ;; Prevent an error message during the install phase.
        ;;   `rebar3 compile' produces symlinks like so in _build/:
        ;;      priv -> ../../../../priv
        ;;      include -> ../../../../include
        ;;
        ;;   The install phase copies whatever has been built to the output directory.
        ;;   If the priv/ directory is absent, then an error `i/o error:
        ;;   _build/…/priv: No such file or directory' occurs. So, we make sure that a
        ;;   directory exists.
        (for-each (lambda (dir) (mkdir-p dir)) (list "priv" "include")))))

(define (configure-HOME . ignored_args)
  "In some cases, it is needed for the environment variable HOME to be defined
as a directory with write permission. Examples of errors:

Could not write to \"/homeless-shelter/.cache/rebar3/hex\". Please ensure the path is writeable.
"
  (let ((HOME "HOME")
        (tmp "/tmp"))
    (setenv HOME tmp)
    (format #t "~a=~a\n" HOME tmp)))

(define* (configure-dependencies #:key
                                 (install-profile "default")
                                 inputs
                                 name
                                 sources-erlang ;List of Source.
                                 version
                                 #:allow-other-keys)
  "Rebar3 refuses to compile without network access unless its dependencies are
present as source checkouts. To prevent unnecessary compilations, we must «
pre-install » dependencies in Rebar's build directory."

  ;; If source in sources-erlang, then install it under _checkouts/.
  (let ((_checkouts "_checkouts"))
    (mkdir-p _checkouts)

    (define (install-source source)
      "Install the Source SOURCE in _checkouts."
      (match source
        ((name path)
         (let ((src (string-append _checkouts sep name)))
           (mkdir-p src)
           (with-directory-excursion src (unpack #:source path))))
        (_ #f)))

    (for-each install-source sources-erlang))

  ;; If input in inputs is an Erlang package, then install it under _build/.
  (let ((_build (format #f "_build/~a/checkouts" install-profile)))
    (mkdir-p _build)

    (define (install-libdir elib name dest)
      "Install the library directory named NAME from ELIB to DEST."
      (let ((src (string-append elib sep name))
            (dest (string-append dest sep (libdir-name->prefix name))))
        (copy-recursively src dest)
        (mkdir-p (string-append dest "/priv"))))

    (define (install-all-libdirs dir dest)
      "Install in DEST all library directories in DIR."
      (let ((elib (string-append dir sep lib-erlang-lib)))
        (when (directory-exists? elib)
          (for-each (lambda (name) (install-libdir elib name dest))
                    (list-directories elib)))))

    (match inputs
      (((_ . dirs) ..1)
       (for-each
        (lambda (dir) (install-all-libdirs dir _build))
        dirs))
      (_ #f))))

(define* (build #:key name (rebar-flags '()) #:allow-other-keys)
  (apply invoke `("rebar3" "compile" ,@rebar-flags)))

(define* (check #:key target
                (rebar-flags '())
                (tests? (not target))
                (test-target "eunit")
                #:allow-other-keys)
  (if tests?
      (apply invoke `("rebar3" ,test-target ,@rebar-flags))
      (format #t "test suite not run~%")))

(define* (install #:key name outputs (install-profile "default") #:allow-other-keys)
  (let* ((src (pkg-name->build-dir name #:profile install-profile))
         (dest (string-append (assoc-ref outputs "out")
                              sep lib-erlang-lib sep
                              (pkg-name->libdir-name name))))
    (mkdir-p dest)
    (copy-recursively src dest #:follow-symlinks? #t)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (add-after 'unpack 'configure-HOME configure-HOME)
    (delete 'bootstrap)
    (delete 'configure)
    (add-before 'build 'configure-dependencies configure-dependencies)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (rebar-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args)
  "Build the given Erlang package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; rebar-build-system.scm ends here