;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Brett Gilio <brettg@gnu.org>
;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
;;; Copyright © 2021, 2022 Philip McGrath <philip@philipmcgrath.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 chez-and-racket-bootstrap)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages ghostscript)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages ncurses)
  #:use-module (gnu packages netpbm)
  #:use-module (gnu packages tex)
  #:use-module (gnu packages xorg)
  #:use-module ((guix licenses)
                #:prefix license:))

;; Commentary:
;;
;; Alphabetically and chronologically, Chez comes before Racket.
;;
;; The bootstrapping paths for Chez Scheme and Racket are closely
;; entwined. Racket CS (the default Racket implementation) is based on (a fork
;; of) Chez Scheme. Racket's variant of Chez Scheme shares sources for
;; nanopass and stex with upstream Chez Scheme.
;;
;; Racket's variant of Chez Scheme can be bootstrapped by an older Racket
;; implementation, Racket BC, which can be bootstrapped from C. Porting that
;; code to work with upstream Chez Scheme (or finding an old version that
;; does) is our best hope for some day bootstrapping upstream Chez Scheme from
;; source.
;;
;; Putting the relevant definitions together in this module avoids having to
;; work around dependency cycles.
;;
;; Code:

(define nanopass
  (let ((version "1.9.2"))
    (origin
      (method git-fetch)
      (uri (git-reference
            (url "https://github.com/nanopass/nanopass-framework-scheme")
            (commit (string-append "v" version))))
      (sha256 (base32 "16vjsik9rrzbabbhbxbaha51ppi3f9n8rk59pc6zdyffs0vziy4i"))
      (file-name (git-file-name "nanopass" version)))))

(define stex
  ;; This commit includes a fix, which we would otherwise want to use as
  ;; patch.  Let's revert to tagged releases as soon as one becomes available.
  (let* ((commit "54051494434a197772bf6ca5b4e6cf6be55f39a5")
         (version "1.2.2")
         (version (git-version version "1" commit)))
    (origin
      (method git-fetch)
      (uri (git-reference
            (url "https://github.com/dybvig/stex")
            (commit commit)))
      (sha256 (base32 "01jnvw8qw33gnpzwrakwhsr05h6b609lm180jnspcrb7lds2p23d"))
      (file-name (git-file-name "stex" version)))))

(define-public chez-scheme
  (package
    (name "chez-scheme")
    (version "9.5.6")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/cisco/ChezScheme")
             (commit (string-append "v" version))))
       (sha256
        (base32 "07s433hn1z2slfc026sidrpzxv3a8narcd40qqr1xrpb9012xdky"))
       (file-name (git-file-name name version))
       (snippet
        ;; Remove bundled libraries.
        (with-imported-modules '((guix build utils))
          #~(begin
              (use-modules (guix build utils))
              (for-each (lambda (dir)
                          (when (directory-exists? dir)
                            (delete-file-recursively dir)))
                        '("stex"
                          "nanopass"
                          "lz4"
                          "zlib")))))))
    (build-system gnu-build-system)
    (inputs
     `(("libuuid" ,util-linux "lib")
       ("zlib" ,zlib)
       ("zlib:static" ,zlib "static")
       ("lz4" ,lz4)
       ("lz4:static" ,lz4 "static")
       ;; for expeditor:
       ("ncurses" ,ncurses)
       ;; for X11 clipboard support in expeditor:
       ;; https://github.com/cisco/ChezScheme/issues/9#issuecomment-222057232
       ("libx11" ,libx11)))
    (native-inputs
     `(("nanopass" ,nanopass) ; source only
       ;; for docs
       ("stex" ,stex)
       ("xorg-rgb" ,xorg-rgb)
       ("texlive" ,(texlive-updmap.cfg (list texlive-dvips-l3backend
                                             texlive-epsf
                                             texlive-fonts-ec
                                             texlive-oberdiek)))
       ("ghostscript" ,ghostscript)
       ("netpbm" ,netpbm)))
    (native-search-paths
     (list (search-path-specification
            (variable "CHEZSCHEMELIBDIRS")
            (files (list (string-append "lib/csv" version "-site"))))))
    (outputs '("out" "doc"))
    (arguments
     `(#:modules
       ((guix build gnu-build-system)
        (guix build utils)
        (ice-9 ftw)
        (ice-9 match))
       #:test-target "test"
       #:configure-flags
       '("--threads") ;; TODO when we fix armhf, it doesn't support --threads
       #:phases
       (modify-phases %standard-phases
         ;; put these where configure expects them to be
         (add-after 'unpack 'unpack-nanopass+stex
           (lambda* (#:key native-inputs inputs #:allow-other-keys)
             (for-each (lambda (dep)
                         (define src
                           (assoc-ref (or native-inputs inputs) dep))
                         (copy-recursively src dep
                                           #:keep-mtime? #t))
                       '("nanopass" "stex"))))
         ;; NOTE: the custom Chez 'configure' script doesn't allow
         ;; unrecognized flags, such as those automatically added
         ;; by `gnu-build-system`.
         (replace 'configure
           (lambda* (#:key inputs outputs
                           (configure-flags '())
                           #:allow-other-keys)
             (let* ((zlib-static (assoc-ref inputs "zlib:static"))
                    (lz4-static (assoc-ref inputs "lz4:static"))
                    (out (assoc-ref outputs "out"))
                    ;; add flags which are always required:
                    (flags (cons*
                            (string-append "--installprefix=" out)
                            (string-append "ZLIB=" zlib-static "/lib/libz.a")
                            (string-append "LZ4=" lz4-static "/lib/liblz4.a")
                            ;; Guix will do compress man pages,
                            ;; and letting Chez try causes an error
                            "--nogzip-man-pages"
                            configure-flags)))
               (format #t "configure flags: ~s~%" flags)
               ;; Some makefiles (for tests) don't seem to propagate CC
               ;; properly, so we take it out of their hands:
               (setenv "CC" ,(cc-for-target))
               (setenv "HOME" "/tmp")
               (apply invoke
                      "./configure"
                      flags))))
         ;; The binary file name is called "scheme" as is the one from MIT/GNU
         ;; Scheme.  We add a symlink to use in case both are installed.
         (add-after 'install 'install-symlink
           (lambda* (#:key outputs #:allow-other-keys)
             (let* ((out (assoc-ref outputs "out"))
                    (bin (string-append out "/bin"))
                    (lib (string-append out "/lib"))
                    (name "chez-scheme"))
               (symlink (string-append bin "/scheme")
                        (string-append bin "/" name))
               (map (lambda (file)
                      (symlink file (string-append (dirname file)
                                                   "/" name ".boot")))
                    (find-files lib "scheme.boot")))))
         ;; Building explicitly lets us avoid using substitute*
         ;; to re-write makefiles.
         (add-after 'install-symlink 'prepare-stex
           (lambda* (#:key native-inputs inputs outputs #:allow-other-keys)
             (let* ((stex+version
                     (strip-store-file-name
                      (assoc-ref (or native-inputs inputs) "stex")))
                    ;; Eventually we want to install stex as a real
                    ;; package so it's reusable. For now:
                    (stex-output "/tmp")
                    (doc-dir (string-append stex-output
                                            "/share/doc/"
                                            stex+version)))
               (with-directory-excursion "stex"
                 (invoke "make"
                         "install"
                         (string-append "LIB="
                                        stex-output
                                        "/lib/"
                                        stex+version)
                         (string-append "Scheme="
                                        (assoc-ref outputs "out")
                                        "/bin/scheme"))
                 (for-each (lambda (pth)
                             (install-file pth doc-dir))
                           '("ReadMe" ; includes the license
                             "doc/stex.html"
                             "doc/stex.css"
                             "doc/stex.pdf"))))))
         ;; Building the documentation requires stex and a running scheme.
         ;; FIXME: this is probably wrong for cross-compilation
         (add-after 'prepare-stex 'install-doc
           (lambda* (#:key native-inputs inputs outputs #:allow-other-keys)
             (let* ((chez+version (strip-store-file-name
                                   (assoc-ref outputs "out")))
                    (stex+version
                     (strip-store-file-name
                      (assoc-ref (or native-inputs inputs) "stex")))
                    (scheme (string-append (assoc-ref outputs "out")
                                           "/bin/scheme"))
                    ;; see note on stex-output in phase build-stex, above:
                    (stexlib (string-append "/tmp"
                                            "/lib/"
                                            stex+version))
                    (doc-dir (string-append (assoc-ref outputs "doc")
                                            "/share/doc/"
                                            chez+version)))
               (define* (stex-make #:optional (suffix ""))
                 (invoke "make"
                         "install"
                         (string-append "Scheme=" scheme)
                         (string-append "STEXLIB=" stexlib)
                         (string-append "installdir=" doc-dir suffix)))
               (with-directory-excursion "csug"
                 (stex-make "/csug"))
               (with-directory-excursion "release_notes"
                 (stex-make "/release_notes"))
               (with-directory-excursion doc-dir
                 (symlink "release_notes/release_notes.pdf"
                          "release_notes.pdf")
                 (symlink "csug/csug9_5.pdf"
                          "csug.pdf"))))))))
    ;; Chez Scheme does not have a  MIPS backend.
    ;; FIXME: Debian backports patches to get armhf working.
    ;; We should too. It is the Chez machine type arm32le
    ;; (no threaded version upstream yet, though there is in
    ;; Racket's fork), more specifically (per the release notes) ARMv6.
    (supported-systems (fold delete %supported-systems
                             '("mips64el-linux" "armhf-linux")))
    (home-page "https://cisco.github.io/ChezScheme/")
    (synopsis "R6RS Scheme compiler and run-time")
    (description
     "Chez Scheme is a compiler and run-time system for the language of the
Revised^6 Report on Scheme (R6RS), with numerous extensions.  The compiler
generates native code for each target processor, with support for x86, x86_64,
and 32-bit PowerPC architectures.")
    (license license:asl2.0)))