;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 rakudo-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (%standard-phases
            rakudo-build))

;; Commentary:
;;
;; Builder-side code of the Rakudo build procedure for Raku packages.
;;
;;
;; The rakudo-build-system uses the Rakudo compiler to compile and install Raku
;; programs, and then uses a Raku test runner (e.g., Zef) to test those
;; programs.  The Rakudo build system is an extension of the GNU build system
;; that is customized ways to support Raku packages, especially for
;; precompilation.  The Rakudo build system accepts one non-standard argument:
;;
;;  #:test-runner - The Test Anything Protocol program used to run tests.
;;                  (ignored if #:tests? #f)
;;  Valid values: "zef"    - [default] Use perl6-zef, which is closest to how 
;;                           tests are normally run in the Raku ecosystem.
;;                "prove6" - Use perl6-prove6, a Raku TAP test runner
;;                "rakudo" - Run tests directly via Rakudo (no TAP test runner)
;;
;; This build system configures Raku programs to write a metadata cache to
;; $XDG_DATA_HOME/raku/repo
;;
;; The above should be all you need to know to package Raku programs with the
;; Rakudo build system; the rest of this commentary provides background on the
;; build system and Raku precompilation generally.
;;
;; Raku's strategy for dependency management is remarkably similar to Guix's:
;; Raku compiles each program into an immutable output; then, whenever that
;; program's (recursive) inputs change, Raku generates a new output and
;; redirects the relevant references to that new output.  This gives Raku many
;; of the same advantages that Guix enjoys, including allowing simultaneous
;; installation of multiple package versions.
;;
;; But the similarity between Guix and Raku creates an issue for packaging Raku
;; programs: Raku expects to be able to manage its equivalent to /gnu/store/ by
;; recompiling Raku programs in their install location.  This doesn't work when
;; those programs are installed in Guix's actual, read-only /gnu/store/.  Thus,
;; integrating Raku and Guix requires some care.
;;
;; Specifically, because Raku can't update precomp files in /gnu/store/, Guix
;; needs replace Raku as the director of Raku's precomp process, including by
;; guaranteeing that every Raku package is fully precompiled at install time.
;; This is different from how Raku normally handles precomp (partly lazily, with
;; some precomp delayed until a module is first loaded).
;;
;; Accordingly, the Rakudo build system installs all precomp files to the store.
;; The only non-store data a Raku package should generate is a metadata index
;; consisting of *.repo-id files and *.lock files that gets written to
;; $XDG_DATA_HOME/raku/repo.  Raku reads this index to avoid the need to check
;; input integrity, which is purely a performance optimization – Raku
;; automatically rebuilds the index if it's missing.
;;
;; The Rakudo build system supports using Guix-installed packages in combination
;; with Zef-installed ones.  (Zef is the LPM (language package manager) that
;; Raku developers use, i.e., Raku's equivalent to Rust's Cargo or JavaScript's
;; NPM/Yarn/PNPM.)  Programs installed via Zef have all their data installed to
;; the same ./raku/repo directory used for Guix-installed packages' metadata.
;; After installation, Zef-installed packages be used interchangeably with Raku
;; packages installed via Guix – though, of course, they lack access to
;; rollbacks, build transformations, and the rest of Guix's superpowers.
;;
;; Including Raku precomp files in the Guix store creates one minor issue: it
;; decreases the number of Raku packages that pass "guix build --check".  This
;; shouldn't be the case: In theory, Raku precomp files are bit-for-bit
;; reproducible but, in practice, a few precomp files show (extremely minor)
;; differences.  Until that's fixed, excluding precomp files from Guix's store
;; would let some Raku packages appear to be fully reproducible.  But doing that
;; wouldn't *actually* help reproduciblity: those slightly non-reproducible
;; precomp files would still be generated and executed outside the store.
;;
;; The Rakudo build system does not yet have an importer, but creating one is
;; conceptually simple and is planned.
;;
;;
;; Code:


(define (raku-input? input)
  "Test if an input appears to be a Rakudo program based on its name."
  (or (string-prefix? "raku-"  (car input))
      (string-prefix? "perl6-" (car input))))

(define (with-vendor-path dir)
  "Append the /share/perl6/vendor path to a directory path"
  (string-append dir "/share/perl6/vendor"))

(define (inputs->raku-vendor-paths inputs)
  "Map a list of Guix inputs into a list of Raku vendor paths."
  (let* ((raku-inputs (filter raku-input? inputs))
         (raku-input-paths (map cdr raku-inputs)))
    (map with-vendor-path raku-input-paths)))

(define (dir->inst dir-path)
  "Produce a CompUnit::Repository::Installation path from a directory path.
Raku provides several types of Repositories, most relevantly 'FileSystem' repos
and 'Installation' repos.  Guix should use Installation repos, which support
installation of multiple versions.  To specify an Installation repo, the path
should be prefixed with 'inst#'"
  (string-append "inst#" dir-path))

(define (copy-raku-dependencies inputs out-dir)
  "Recursively copy files from each Raku dependency to the out directory. This
lets Rakudo find the precomp files without recursively checking the integrity of
each one (which is prohibitively slow).  Copying the files doesn't increase disk
usage thanks to Guix's deduplication via hard links."
      (let* ((raku-inputs (filter raku-input? inputs))
             (raku-input-paths  (map (lambda (input)
                                      (with-vendor-path (cdr input)))
                                     raku-inputs)))
        (mkdir-p out-dir)
        (for-each
         (lambda (source-dir)
           (for-each make-file-writable (find-files out-dir))
           (copy-recursively source-dir out-dir))
         raku-input-paths)))

(define (set-repository-version repository-dir version)
  "Set the repository format version for a Raku repository.  Raku repositories
have used incompatible formats and an unspecified version defaults to v1; thus,
Raku packages must set the repo version.  NOTE: the 'install-dist.raku' script
cleans up the version marker, so you may need to set the version again.
Forgetting to set the version currently triggers a cryptic error that includes
the text `cannot do '.open' on a directory'."
  ;; see https://github.com/Raku/old-issue-tracker/issues/6422
  ;; TODO: Consider upstreaming a patch to provide a less cryptic error msg.
  (let ((version-file (open-output-file "version")))
    (format version-file "~a\n" version)
    (close-port version-file)
    (install-file "version" repository-dir)))

(define* (validate-keyword-arg keyword allowed-values
                               #:key (keyword-name "a keyword argument"))
  "Check that the keyword argument has one of the allowed values."
  (unless (member keyword allowed-values)
    (let ((allowed-strings (map (cut format #f "~s" <>) allowed-values)))
    (raise
     (condition
      (&message (message
                 (format #f "Invalid value for ~a: '~s'"
                         keyword-name keyword)))
      (&message (message
                 (format #f "Valid values: '~a'."
                         (string-join allowed-strings "', '")))))))))

(define (extract-provided-modules meta6)
  "Extract the list of provided modules from a packages META6.json file."
  ;; Could alternatively use (json->scm), at the cost of a build dependency
  (let* ((q-mark "\"")
         (non-quote "[^\"]+")
         (json-key (string-append q-mark "(" non-quote ")" q-mark ))
         (json-value (string-append q-mark non-quote q-mark))
         (json-key-value (make-regexp (string-append non-quote json-key
                                                     non-quote json-value)))
         (json-provides-field "[,{]\\s*\"provides\"")
         (provides-value-regexp
          (make-regexp
           (string-append json-provides-field
                          "\\s*:\\s*"
                          "\\{([^}]+)\\}")))
         (provides-value (regexp-exec provides-value-regexp meta6)))
    (map (cut match:substring <> 1)
         (list-matches json-key-value
                       (match:substring provides-value 1)))))

;;; Phases

(define* (setup-rakudo-env #:key inputs outputs #:allow-other-keys)
  "Set various RAKUDO* environment variables."
  (let* ((out (assoc-ref outputs "out"))
         (dest (with-vendor-path out))
         (rakudo-dir (assoc-ref inputs "rakudo"))
         (rakudo-home (string-append rakudo-dir "/share/perl6"))
         (raku-vendor-paths (inputs->raku-vendor-paths inputs))
         (raku-installations (map dir->inst raku-vendor-paths)))
    
    (setenv "HOME" (getcwd))
    (setenv "RAKUDO_HOME" rakudo-home)
    (setenv "RAKUDO_RESOLVE_DEPENDENCIES" "0")
    (setenv "RAKUDO_LOG_PRECOMP"  "1")
    (setenv "RAKUDO_MODULE_DEBUG" "1")
    (setenv "RAKULIB"
            (string-append (dir->inst dest) "," "home,"
                           (string-join raku-installations ",")))))


(define* (check #:key tests? test-runner inputs #:allow-other-keys)
  "Run the tests in ./t with the supplied #:test-runner (default: zef) unless
#:tests? is #f."
  (validate-keyword-arg test-runner '("zef" "prove6" "rakudo")
                        #:keyword-name "test-runner")
  (when tests?
    (cond
     ((eq? test-runner "zef")
      (let* ((zef-dir (assoc-ref inputs "test-runner-zef"))
             (zef (string-append zef-dir "/bin/zef")))
        (invoke zef "test" ".")))
     ((eq? test-runner "prove6")
      (let* ((prove6-dir (assoc-ref inputs "test-runner-prove6"))
             (prove6 (string-append prove6-dir "/bin/prove6")))
        (invoke prove6 "-Ilib" "t/")))
     ((eq? test-runner "rakudo")
      (let* ((rakudo-dir (assoc-ref inputs "rakudo"))
             (rakudo (string-append rakudo-dir "/bin/rakudo")))
        (for-each (cut invoke rakudo "-Ilib" <>)
                  (find-files "t/")))))))

(define* (install #:key inputs outputs #:allow-other-keys)
  "Install the code of a given Raku package."
  (let* ((out (assoc-ref outputs "out"))
         (vendor-dir (with-vendor-path out))
         (rakudo-dir (assoc-ref inputs "rakudo"))
         (install-dist-script (string-append rakudo-dir
                               "/share/perl6/tools/install-dist.raku")))

    (copy-raku-dependencies inputs vendor-dir)
    (set-repository-version vendor-dir 2)

    (invoke install-dist-script
            "--from=."
            (string-append "--to=" vendor-dir)
            "--for=vendor"
            "--build"
            "--precompile")))

(define* (install-resources #:key outputs #:allow-other-keys)
  "Install the resources supplied by a Raku package.  Resources are typically
items such as configuration or data files; for details, see
https://docs.raku.org/language/variables#%?RESOURCES"
  (when (file-exists? "resources")
    (let* ((out  (assoc-ref outputs "out"))
           (resources-dir (string-append out "/share/perl6/resources")))
      (copy-recursively "resources" resources-dir))))

(define* (install-bins #:key outputs #:allow-other-keys)
  "Install any binary programs supplied by a Raku package."

  (define (install-file-list file-list target-dir)
    (for-each (cut install-file <> target-dir) file-list))

  (let* ((binary-dirs (filter file-exists? '("bin" "sbin")))
         (out  (assoc-ref outputs "out")))
    (when binary-dirs
     (for-each (lambda (binary-dir)
                 (install-file-list (find-files binary-dir)
                                    (string-append out "/" binary-dir)))
               binary-dirs))))

(define* (wrap-raku-programs #:key inputs outputs #:allow-other-keys)
  "Wrap executable Raku programs to ensure they always uses the correct inputs 
(including the correct Rakudo version) even if other versions are installed."

  (define (with-rakulib program rakulib)
    (wrap-program program #:sh (search-input-file inputs "bin/sh")
                  `("RAKULIB" "," prefix ,rakulib)))

  (let ((out (assoc-ref outputs "out")))
    (define bin-dirs
      (filter directory-exists?
              (list (string-append out "/bin")
                    (string-append out "/sbin"))))
    (unless (eq? bin-dirs '())
      (let* ((bin-files (fold append '() (map find-files bin-dirs)))
             (wrappable-bin-files (filter (negate wrapped-program?) bin-files))
             (raku-vendor-paths (inputs->raku-vendor-paths inputs))
             (raku-installations (map dir->inst raku-vendor-paths))
             (current-installation (dir->inst (with-vendor-path out)))
             (xdg-data-home-inst "inst#${XDG_DATA_HOME:-$HOME/.local/share}")
             (guix-pkg-index-file (string-append xdg-data-home-inst
                                                  "/raku/repo")))
        (for-each (cut with-rakulib
                       <>
                       (append (list current-installation)
                               raku-installations
                               (list guix-pkg-index-file)))
                  wrappable-bin-files)))))

(define* (precompile #:key inputs outputs #:allow-other-keys)
  "Fully precompile all Raku code."
  (let ((provides (extract-provided-modules (read-string (open-input-file "META6.json")))))
    (let* ((out (assoc-ref outputs "out"))
               (rakudo-dir (assoc-ref inputs "rakudo"))
               (rakudo (string-append rakudo-dir "/bin/.rakudo-real")))
          (setenv "RAKULIB" (dir->inst (with-vendor-path out)))
          (for-each (lambda (module)
                      (invoke rakudo
                              "-c" ; compile w/o running
                              "-e" (string-append "use " module)))
                    provides))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'build)
    (add-after 'unpack 'setup-rakudo-environment setup-rakudo-env)
    (replace 'check check)
    (replace 'install install)
    (add-after 'install 'install-resources install-resources)
    (add-after 'install-resources 'install-binaries install-bins)
    ;; needs to be after 'install-binaries
    (add-after 'install-binaries 'wrap-raku-programs wrap-raku-programs)
    (add-after 'wrap-raku-programs 'precompile-raku-modules precompile)))

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


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