;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 B. Wilson <elaexuotee@wilsonb.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 (gnu packages jsoftware)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix build utils)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (gnu packages libedit)
  #:use-module (gnu packages llvm)
  #:use-module (gnu packages maths)
  #:use-module (guix gexp)
  #:use-module (ice-9 match))


(define (jname prefix jtype)
  "Return a package name for the given prefix and jtype, e.g. `jlib',
  `jlib-beta', `j', and `j-beta'."
  (let ((postfix (if (eq? jtype 'release) ""
                   (string-append "-" (symbol->string jtype)))))
    (string-append prefix postfix)))

(define (jversion->string version revision)
  "Return a string representation of a J version and (optional) revision pair."
  (let ((postfix (if (not revision) ""
                   (string-append "-" revision))))
    (string-append version postfix)))

(define (jinfo->git-tag jversion jtype jrevision)
  "Given version parameters, construct a git tag for upstream releases."
  (let ((postfix (if (not jrevision) ""
                   (string-append "-" jrevision))))
    (string-append "j" jversion "-" (symbol->string jtype) postfix)))

(define-record-type* <jlib-build-configuration>
  jlib-build-configuration make-jlib-build-configuration
  jlib-build-configuration?
  (builder      jlib-build-configuration-builder (default "guix.gnu.org"))
  (version      jlib-build-configuration-version (default #f))
  (revision     jlib-build-configuration-revision (default #f))
  (hash         jlib-build-configuration-hash (default #f))
  (type         jlib-build-configuration-type (default 'release))
  (patches      jlib-build-configuration-patches (default '()))
  (extra-inputs jlib-build-configuration-extra-inputs (default '()))
  (extra-envars jlib-build-configuration-extra-envars (default '())))

(define make-jlib
  (match-lambda
    (($ <jlib-build-configuration>
        builder jversion revision hash type patches extra-inputs extra-envars)
     (package
       (name (jname "jlib" type))
       (version (jversion->string jversion revision))
       (source
        (origin
          (method git-fetch)
          (uri (git-reference
                (url "https://github.com/jsoftware/jsource")
                (commit (jinfo->git-tag jversion type revision))))
          (sha256 (base32 hash))
          (file-name (git-file-name name version))
          (patches patches)))
       (properties `((jversion . ,jversion)
                     (jrevision . ,revision)
                     (jtype . ,type)))
       (build-system gnu-build-system)
       (native-inputs `(("clang-toolchain" ,clang-toolchain)))
       (inputs (cons* `("libedit" ,libedit)
                      `("libomp" ,libomp)
                      extra-inputs))
       (arguments
        `(#:modules (((ice-9 ftw) #:select (scandir))
                     ((ice-9 popen) #:select (open-pipe* close-pipe))
                     ((ice-9 regex) #:select (match:substring string-match))
                     ((ice-9 threads) #:select (parallel par-for-each))
                     ((srfi srfi-26) #:select (cut))
                     ((srfi srfi-1) #:select (fold))
                     ,@%gnu-build-system-modules)
          #:phases
          ;; Upstream's build system consists of ad-hoc scripts that build
          ;; build up (very complicated) environment variables to pass to make.
          ;; The basic build process looks like this:
          ;;
          ;;   1) Copy jsrc/jversion-x.h to jsrc/jversion.h and edit values;
          ;;   2) Set jplatform and j64x environment variables;
          ;;   3) Run make2/build_jconsole.sh and make2/build_libj.sh;
          ;;
          ;; However, upstream expects users to run J directly from the source
          ;; directory; they do not supply a make `install' target.  Thus it
          ;; takes some massaging to install files in FHS-style directories.
          (modify-phases %standard-phases
            ;; In particular, we have to set up
            ;;
            ;;   1) jsrc/jversion.h as in a typical build;
            ;;   2) jlibrary/bin/profilex.ijs to point to writable directories;
            ;;   3) make2/build_*.sh to respect standard build conventions;
            ;;   4) jsrc/jconsole.c to fix libedit dlopen; and
            ;;   5) Hard coded references to addons directory.
            (replace 'configure
              (lambda* (#:key target inputs outputs #:allow-other-keys)
                (let* ((clang-toolchain (assoc-ref inputs "clang-toolchain"))
                       (clang (string-append clang-toolchain "/bin/clang"))
                       (libedit (assoc-ref inputs "libedit"))
                       (out (assoc-ref outputs "out"))
                       (share (string-append out "/share/j")))
                  ;; Set up build constants
                  (copy-file "jsrc/jversion-x.h" "jsrc/jversion.h")
                  (substitute* "jsrc/jversion.h"
                    (("^#define jversion.*$")
                     (format #f "#define jversion ~s\n" ,version))
                    (("^#define jtype.*$")
                     (format #f "#define jtype ~s\n" (symbol->string ',type)))
                    (("^#define jbuilder.*$")
                     (format #f "#define jbuilder ~s\n" ,builder)))
                  ;; Create profilex.ijs overrides to point to the correct
                  ;; store items.  Note that we set ~install and ~addons
                  ;; directories to reside under ~user to allow installing
                  ;; and loading addons.  TODO: Guix-ify J addons as well.
                  (call-with-output-file "jlibrary/bin/profilex.ijs"
                    (lambda (port)
                      (display
                        (string-join
                          (list
                            (format #f "system=. '~a/system'" share)
                            (format #f "tools=. '~a/tools'" share)
                            ;; Upstream defaults to spamming $HOME with
                            ;; unhidden userdata directories.  Set this to be
                            ;; $HOME/.j/<jtype>/<jversion> instead
                            "'jtype jversion'=. (3&{,{.) <;._2 ,&'/' 9!:14''"
                            "jversion=. ({.~ i.&'-') jversion"
                            "jsuffix=. >@{&('';'-beta') jtype -: 'beta'"
                            "user=. home,'/.j/',jversion,jsuffix"
                            "addons=. user,'/addons'"
                            "break=. user,'/break'"
                            "config=. user,'/config'"
                            "install=. user,'/install'"
                            "snap=. user,'/snap'"
                            "temp=. user,'/temp'"
                            "\n")
                          "\n")
                        port)))
                  ;; Munge the build scripts into reason:
                  ;; 1. Short-circuit the fragile compiler detection;
                  ;; 2. Make sure to include our CFLAGS and LFLAGS; and
                  ;; 3. Propagate script errors to top level.
                  (for-each
                   (lambda (file)
                     (with-directory-excursion "make2"
                       (substitute* file
                         ;; The `compiler' variable doesn't point to the actual
                         ;; compiler.  It is just a switch to tell the build
                         ;; scripts whether to use gcc- or clang-specific
                         ;; flags.
                         (("^compiler=.*$") "compiler=clang\n")
                         (("^LDFLAGS=\"" def) (string-append def "$LDFLAGS "))
                         (("^(common=\")(\\$USETHREAD.*)$" _ def rest)
                          (string-append def "$CFLAGS " rest))
                         (("^#!.*" shebang)
                          (string-append shebang "set -o errexit\n")))))
                     '("build_jconsole.sh" "build_libj.sh"))
                  ;; The jconsole manually loads libedit with dlopen.  The path
                  ;; must be absolute to correctly point to our input.
                  (substitute* "jsrc/jconsole.c"
                    (("libedit\\.so\\.[0-9]" so-file)
                     (format #f "~a/lib/~a" libedit so-file)))
                  ;; The ~addons/dev directory supplies tentative J-script
                  ;; definitions of new J engine functionality.  Since we point
                  ;; ~addons under the ~user directory, we move it under
                  ;; ~system instead, which sits as-is in the output.
                  (with-directory-excursion "jsrc"
                    (for-each
                      (lambda (file)
                        (substitute* file (("~addons/dev") "~system/dev")))
                      (scandir "."
                        (lambda (f) (eq? (stat:type (stat f)) 'regular)))))
                  ;; Implementation of 9!:14 records build time which breaks
                  ;; build reproducibility.  Note that upstream code depends on
                  ;; the exact format of these strings, so we need to mimic the
                  ;; standard.
                  (substitute* "jsrc/j.c"
                    (("__DATE__") "\"Jan 01 1970\"")
                    (("__TIME__") "\"00:00:00\""))
                  ;; Upstream recommends using clang, with GCC support being
                  ;; second-class, often resulting in build failures.
                  (setenv "CC" clang))))
            ;; The build output depends primarily on the values of the
            ;; `jplatform' and `j64x' environment variables.  If the target is
            ;; ARM, then `jplatform' is "raspberry", otherwise it is `linux'.
            ;; In addition to 32- and 64- bit versions, `j64x' controlls
            ;; whether AVX or AVX2 variants of libj are built.
            ;;
            ;; However, build targets are not fine-grained enough to
            ;; distinguish between CPU features.  Thus we build and install all
            ;; variants of libj, expecting jconsole to be called with a wrapper
            ;; script that detects AVX features and loads the appropriate libj
            ;; at runtime.
            (replace 'build
              (lambda _
                (setenv "USE_OPENMP" "1")
                (setenv "USE_THREAD" "1")
                (for-each (lambda (var-val) (apply setenv var-val))
                          (quote ,extra-envars))
                ;; The build scripts assume that PWD is make2.
                (with-directory-excursion "make2"
                  (let* ((platform ,(if (target-arm?) "raspberry" "linux"))
                         (jplat (string-append "jplatform=" platform))
                         (target-bit ,(if (target-64bit?) "64" "32"))
                         (jbit (string-append "j64x=" "j" target-bit))
                         (jbit-avx (string-append jbit "avx"))
                         (jbit-avx2 (string-append jbit "avx2")))
                    (parallel
                      ;; Since jconsole doesn't depend on AVX features, we just
                      ;; build it once.
                      (invoke "env" jplat jbit "./build_jconsole.sh")
                      (invoke "env" jplat jbit "./build_libj.sh")
                      (if ,(target-64bit?)
                        (parallel
                          (invoke "env" jplat jbit-avx "./build_libj.sh")
                          (invoke "env" jplat jbit-avx2
                                  "./build_libj.sh"))))))))
            ;; The test suite is expected to be run as follows for each variant
            ;; of libj that we build:
            ;;
            ;;     $ echo 'RUN ddall' | jconsole test/tsu.ijs
            ;;
            ;; This requires a working jconsole with accessible jlibrary files.
            ;; We simply place these all under test/bin.
            (replace 'check
               (lambda _
                 (let ((jplatform ,(if (target-arm?) "raspberry" "linux")))
                   (mkdir-p "test/bin")
                   (for-each
                     (lambda (dir)
                       (let ((source (string-append "jlibrary/" dir))
                             (dest (string-append "test/bin/" dir)))
                       (begin
                         (mkdir-p dest)
                         (copy-recursively source dest))))
                     '("system" "tools" "addons"))
                   ;; The jlibrary/dev directory only sometimes exists, but
                   ;; needs to be copied into the ~system directory when it
                   ;; does.
                   (if (access? "jlibrary/dev" R_OK)
                     (copy-recursively "jlibrary/dev" "test/bin/system/dev"))
                   (par-for-each
                     (lambda (dir)
                       (let* ((jbin (string-append "bin/" jplatform))
                              (jbit ,(if (target-64bit?) "j64" "j32"))
                              (jconsole (string-append jbin "/" jbit
                                                       "/jconsole"))
                              (source (string-append jbin "/" dir))
                              (dest (string-append "test/bin/" dir)))
                         (begin
                           (mkdir-p dest)
                           (copy-recursively source dest)
                           (install-file "jlibrary/bin/profile.ijs" dest)
                           (install-file jconsole dest)
                           (let* ((jc (string-append dest "/jconsole"))
                                  (tests "test/tsu.ijs")
                                  (port (open-pipe* OPEN_WRITE jc tests)))
                             (display "RUN ddall\n" port)
                             (when (not (zero? (status:exit-val
                                                 (close-pipe port))))
                               (error "Some J build tests failed."))))))
                     (scandir (string-append "bin/" jplatform)
                              (negate (cut member <> '("." "..")))))
                   #t)))
            ;; Now that everything is built, installation is fairly
            ;; straightforward, following FHS conventions.  The only quirk is
            ;; that we install jconsole under /libexec to make room for the
            ;; wrapper replacement under /bin.
            (replace 'install
              (lambda* (#:key outputs inputs #:allow-other-keys)
                (let* ((jplat ,(if (target-arm?) "raspberry" "linux"))
                       (jbit ,(if (target-64bit?) "j64" "j32"))
                       (jconsole (string-join
                                   `("bin" ,jplat ,jbit "jconsole") "/"))
                       (out (assoc-ref outputs "out"))
                       (etc (string-append out "/etc/j"))
                       (lib (string-append out "/lib/j"))
                       (libexec (string-append out "/libexec"))
                       (share (string-append out "/share/j"))
                       (system (string-append share "/system"))
                       (dev (string-append system "/dev")))
                  (mkdir-p lib)
                  (for-each
                    (lambda (jarch)
                      (let* ((jbin (string-join `("bin" ,jplat ,jarch) "/"))
                             (javx-match (string-match "avx.*" jarch))
                             (javx (if (not javx-match) ""
                                     (match:substring javx-match)))
                             (sep (if javx-match "-" ""))
                             (source (string-append jbin "/libj.so"))
                             (dest (format #f "~a/libj~a~a.so" lib sep javx)))
                        (copy-file source dest)))
                    (scandir (string-append "bin/" jplat)
                             (negate (cut member <> '("." "..")))))
                  (install-file jconsole libexec)
                  (copy-recursively "jlibrary/system" system)
                  (if (access? "jlibrary/dev" R_OK)
                    (copy-recursively "jlibrary/dev" dev))
                  (install-file "jlibrary/bin/profile.ijs" etc)
                  (install-file "jlibrary/bin/profilex.ijs" etc)))))))
       (home-page "https://www.jsoftware.com/")
       (synopsis "Ascii-only, array programming language in the APL family")
       (description
     "J is a high-level, general-purpose programming language that is
particularly suited to the mathematical, statistical, and logical analysis of
data. It is a powerful tool for developing algorithms and exploring problems
that are not already well understood.")
       (license license:gpl3+)))))


(define jlib-901
  (make-jlib
    (jlib-build-configuration
      (version "901")
      (revision "f")
      (hash "1776021m0j1aanzwg60by83n53pw7i6afd5wplfzczwk8bywax4p")
      (patches (search-patches "jsoftware-j901-f-fixes.patch")))))


(define jlib-build-configuration-with-sleef
  (jlib-build-configuration
    (extra-inputs `(("sleef" ,sleef)))
    (extra-envars `(("USE_SLEEF_SRC" "0")
                    ("LDFLAGS" "-lsleef")))))

(define jlib-902
  (make-jlib
    (jlib-build-configuration
      (inherit jlib-build-configuration-with-sleef)
      (version "902")
      (revision "b")
      (hash "0j67vgikqflwjqacsdicasvyv1k54s2c8vjgwmf0ix7l41p4xqz0"))))

(define jlib-903-beta
  (make-jlib
    (jlib-build-configuration
      (inherit jlib-build-configuration-with-sleef)
      (version "903")
      (revision "h")
      (type 'beta)
      (hash "13sw2ffgx6pm699qfi50drlp8y1vmzj4swzx82g6vhyjpjci1w4h"))))


(define (make-ijconsole jlib)
  "Generate a G-exp wrapper script that detects AVX/AVX2 support at runtime and
  executes jconsole with the appropriate libj.so and profile.ijs."
  (program-file (string-append "ijconsole-" (package-version jlib))
    #~(begin
        (use-modules ((ice-9 rdelim) #:select (read-line))
                     ((ice-9 regex) #:select (regexp-match? string-match)))

        (define (cpu-feature-line? string)
          (string-prefix? "flags" string))

        (define (contains-word? word string)
          (regexp-match?
            (string-match (string-join `("\\<" ,word "\\>") "")
                          string)))

        (define (has-cpu-feature? feature)
          (with-input-from-file "/proc/cpuinfo"
             (lambda ()
               (catch 'found
                 (lambda ()
                   (let loop ((line (read-line)))
                     (cond ((eof-object? line) #f)
                           ((and (cpu-feature-line? line)
                                 (contains-word? feature line))
                            (throw 'found))
                           (else (loop (read-line))))))
                 (const #t)))))

        (let* ((jconsole (string-append #$jlib "/libexec/jconsole"))
               (libj (format #f "~a/lib/j/libj-~a.so" #$jlib
                             (cond ((has-cpu-feature? "avx2") "avx2")
                                   ((has-cpu-feature? "avx") "avx")
                                   (else ""))))
               (jprofile (string-append #$jlib "/etc/j/profile.ijs")))
          (apply execl jconsole "ijconsole" "-lib" libj "-jprofile" jprofile
                 (cdr (command-line)))))))

(define (make-j jlib)
  "Generate a J package containing /bin/ijconsole-<jversion> linked against the
  given jlib library package.  Note that the ijconsole executable is versioned
  since it is typical for J users to have multiple versions installed on the
  same system."
  (let ((jversion (assq-ref (package-properties jlib) 'jversion))
        (jtype (assq-ref (package-properties jlib) 'jtype)))
    (package (inherit jlib)
      (name (jname "j" jtype))
      (source #f)
      (inputs `(("jlib" ,jlib)
                ("ijconsole" ,(make-ijconsole jlib))))
      (build-system trivial-build-system)
      (arguments
       `(#:modules ((guix build utils))
         #:builder
         (begin
           (use-modules (guix build utils))
           (let* ((ijconsole (assoc-ref %build-inputs "ijconsole"))
                  (out (assoc-ref %outputs "out"))
                  (bin (string-append out "/bin")))
             (mkdir-p bin)
             (symlink ijconsole
                      (string-append bin "/ijconsole-" ,jversion)))))))))

(define-public j-901 (make-j jlib-901))
(define-public j-902 (make-j jlib-902))
(define-public j-903-beta (make-j jlib-903-beta))