;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 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 build utils)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #: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 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-71))


;;; TODO: Make importer and packages for J addons:
;;; http://www.jsoftware.com/jal/

;;; TODO: Package up j80x series


(define (jname prefix release-type)
  "Return a package name for J, including RELEASE-TYPE only if not 'release."
  (match release-type
    ('release prefix)
    (_        (string-append prefix "-" (symbol->string release-type)))))

(define (version-major+minor* version)
  "Like version-major+minor, but returning two string values."
  (let ((parts (string-split version #\.)))
    (values (first parts) (second parts))))

(define* (jrelease-string release-type #:optional version-minor)
  "Construct J release identifier string."
  (let ((release-type (symbol->string release-type)))
    (if version-minor
        (string-append release-type "-" version-minor)
        release-type)))

(define* (jinfo->git-tag version release-type)
  "Given version parameters, construct a git tag for upstream releases."
  (let ((major minor (version-major+minor* version)))
    (string-append "j" major "-" (jrelease-string release-type minor))))

;; G-exp script that detects AVX/AVX2 support at runtime and executes jconsole
;; with the appropriate libj.so and profile.ijs."
;; NOTE: This should be baked in at compile time into `jsoftware-j'.
(define ijconsole
  (with-imported-modules '((guix cpu)
                           (guix memoization)
                           (guix profiling)
                           (guix sets)
                           (srfi srfi-26))
    (program-file "ijconsole"
      #~(begin
          (use-modules ((guix cpu)     #:select (cpu-flags current-cpu))
                       ((guix sets)    #:select (set-contains?))
                       ((srfi srfi-26) #:select (cute)))

          ;; Assume that this script will be installed under bin/.
          (define %basedir (dirname (dirname (current-filename))))

          (let* ((jconsole (string-append %basedir "/libexec/j/jconsole"))
                 (cpu-has-flag?
                   (cute set-contains? (cpu-flags (current-cpu)) <>))
                 (libj (format #f "~a/lib/j/libj~a.so" %basedir
                               ""#;
                               (cond ((cpu-has-flag? "avx2") "-avx2")
                                     ((cpu-has-flag? "avx") "-avx")
                                     (else ""))))
                 (jprofile (string-append %basedir "/etc/j/profile.ijs")))
            (apply execl jconsole "ijconsole" "-lib" libj "-jprofile" jprofile
                   (cdr (command-line))))))))

(define* (make-j base-version hash
                 #:key
                 revision
                 commit
                 tag
                 (release-type 'release)
                 (patches '())
                 (modules '())
                 (snippet #f)
                 (extra-inputs '())
                 (extra-envars '())
                 (builder "guix.gnu.org"))
  (let ((major minor (version-major+minor* base-version)))
    (package
      (name (jname "jsoftware-j" release-type))
      (version
       (if commit (git-version base-version revision commit) base-version))
      (source
       (origin
         (method git-fetch)
         (uri (git-reference
               (url "https://github.com/jsoftware/jsource")
               (commit (or commit tag
                           (jinfo->git-tag base-version release-type)))))
         (sha256 (base32 hash))
         (file-name (git-file-name name version))
         (patches patches)
         (modules modules)
         (snippet snippet)))
      (build-system gnu-build-system)
      (native-inputs (list clang-toolchain))
      (inputs
       ;; ijconsole and profile.ijs still require labels
       `(("ijconsole" ,ijconsole)
         ("profilex.ijs" ,(search-auxiliary-file "jsoftware/profilex.ijs"))
         ("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 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")))
                 ;; 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" ,major))
                   (("^#define jtype.*$")
                    (format #f "#define jtype ~s\n"
                            ,(jrelease-string release-type minor)))
                   (("^#define jbuilder.*$")
                    (format #f "#define jbuilder ~s\n" ,builder)))
                 ;; 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
                 ;; 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"))
                        (target-bit ,(if (target-64bit?) "64" "32"))
                        (run (lambda* (script #:key (avx ""))
                               (invoke "env"
                                       (string-append "jplatform=" platform)
                                       (string-append "j64x=j" target-bit avx)
                                       script))))
                   (parallel
                    ;; Since jconsole doesn't depend on AVX features, we just
                    ;; build it once.
                    (run "./build_jconsole.sh")
                    (run "./build_libj.sh")
                    (when #false ;; ,(target-64bit?)
                      (run "./build_libj.sh" #:avx "avx")
                      (run "./build_libj.sh" #:avx "avx2")))))))
           ;; 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* (#:key tests? #:allow-other-keys)
               (when tests?
                 (let ((platform ,(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 exists sometimes, but
                   ;; when it does, it needs to be in ~system.
                   (for-each
                    (lambda (dev-dir)
                      (if (file-exists? dev-dir)
                          (copy-recursively dev-dir "test/bin/system/dev")))
                    '("jlibrary/dev" "jlibrary/addons/dev"))
                   (par-for-each
                    (lambda (dir)
                      (let* ((bin (string-append "bin/" platform))
                             (jbit ,(if (target-64bit?) "j64" "j32"))
                             (jconsole (string-append bin "/" jbit
                                                      "/jconsole"))
                             (source (string-append bin "/" 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* ((jconsole (string-append dest "/jconsole"))
                                 (tests "test/tsu.ijs")
                                 (port (open-pipe* OPEN_WRITE jconsole tests)))
                            (display "RUN ddall\n" port)
                            (unless (zero? (status:exit-val (close-pipe port)))
                              (error "Some J build tests failed."))))))
                    (scandir (string-append "bin/" platform)
                             (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* ((platform ,(if (target-arm?) "raspberry" "linux"))
                      (jbit ,(if (target-64bit?) "j64" "j32"))
                      (out (assoc-ref outputs "out"))
                      (bin (string-append out "/bin"))
                      (etc (string-append out "/etc/j"))
                      (lib (string-append out "/lib/j"))
                      (libexec (string-append out "/libexec/j"))
                      (share (string-append out "/share/j"))
                      (system (string-append share "/system"))
                      (dev (string-append system "/dev")))
                 (mkdir-p bin)
                 (copy-file (assoc-ref inputs "ijconsole")
                            (string-append bin "/ijconsole-" ,major))
                 (mkdir-p lib)
                 (for-each
                  (lambda (jarch)
                    (let* ((jbin (string-join `("bin" ,platform ,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/" platform)
                           (negate (cut member <> '("." "..")))))
                 (install-file
                  (string-append "bin/" platform "/" jbit "/jconsole")
                  libexec)
                 (copy-recursively "jlibrary/system" system)
                 (for-each
                  (lambda (source-dev)
                    (if (access? source-dev R_OK)
                        (copy-recursively source-dev dev)))
                  '("jlibrary/dev" "jlibrary/addons/dev"))
                 (install-file "jlibrary/bin/profile.ijs" etc)
                 (copy-file (assoc-ref inputs "profilex.ijs")
                            (string-append etc "/profilex.ijs"))))))))
      (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-public jsoftware-j-901
  (make-j "901.f"
          "1776021m0j1aanzwg60by83n53pw7i6afd5wplfzczwk8bywax4p"
          #:patches (search-patches "jsoftware-j901-f-fixes.patch")))


(define j-build-configuration-with-sleef
  ;; XXX: label required because of ijconsole and profile.ijs in make-j.
  ;;      if labels are dropped in make-j, drop them here too.
  ;; XXX: sleef is still being bundled in j and unbundling it causes build
  ;;      errors... investigate them and unbundle
  `(#:extra-inputs (("sleef" ,sleef))
    #:extra-envars (("USE_SLEEF_SRC" "0")
                    ("LDFLAGS" "-lsleef"))))

(define-public jsoftware-j-902
  (apply make-j "902.b"
         "0j67vgikqflwjqacsdicasvyv1k54s2c8vjgwmf0ix7l41p4xqz0"
         j-build-configuration-with-sleef))

(define-public jsoftware-j-903
  (apply make-j "903.a"
         "1fcfl7q7c2vj4fmnqqc8c6hwgsjm20ff93v8xxfniasss1b2fmc4"
         #:tag "903-release-a"
         j-build-configuration-with-sleef))

(define-public (jsoftware-ijconsole-symlink jpkg)
  "Provide bin/ijconsole symlink that points to pkg's
bin/ijconsole-<jversion>."
  (package
    (name "jsoftware-ijconsole")
    (version (package-version jpkg))
    (source #f)
    (build-system trivial-build-system)
    (propagated-inputs `(("jpkg" ,jpkg)))
    (arguments
      `(#:modules ((guix build utils)
                   (srfi srfi-26))
        #:builder
        (begin
          (use-modules ((guix build utils) #:select (mkdir-p))
                       ((ice-9 regex) #:select (string-match))
                       ((ice-9 ftw) #:select (scandir))
                       ((srfi srfi-26) #:select (cut)))
          (let* ((out (assoc-ref %outputs "out"))
                 (jpkg (assoc-ref %build-inputs "jpkg"))
                 (ijconsole (car (scandir (string-append jpkg "/bin")
                                       (cut string-match "ijconsole-.*" <>))))
                 (source (string-append jpkg "/bin/" ijconsole))
                 (dest (string-append out "/bin/ijconsole")))
            (mkdir-p (dirname dest))
            (symlink source dest)))))
  (home-page (package-home-page jpkg))
  (synopsis "Provide `ijconsole' symlink to default interpreter version")
  (description
  "The interpreter provided by the J package has a filename like
ijconsole-<version>, which provides support for having multiple, concurrent
versions installed.  This package provides a version-agnostic `ijconsole'
symlink to interpreter version indicated and build time.")
  (license license:gpl3+)))