path: root/mcgoron/guix/scheme-packages.scm

#| Copyright (C) 2025 Peter McGoron
 |
 | This program 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.
 |
 | This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.
 |#

(define-module (mcgoron guix scheme-packages)
  #:use-module (rnrs base)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (guix licenses)
  #:use-module (guix git-download)
  #:use-module (guix download)
  #:use-module (gnu packages version-control)
  #:use-module (gnu packages bash)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system)
  #:use-module (guix build-system copy)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages scheme)
  #:use-module (gnu packages cmake)
  #:use-module (guix build-system cmake)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages bdw-gc)
  #:use-module (gnu packages libffi)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages textutils)
  #:use-module (gnu packages multiprecision)
  #:use-module (guix gexp))

;;;;;;;;;;;;;
;;;; Portable
;;;;;;;;;;;;;

(define-public r7rs-lib-dir "share/scheme/r7rs")
(define-public r6rs-lib-dir "share/scheme/r6rs")

(define-public (default-copying-build-system name desc dir)
  (let ((lower* (build-system-lower copy-build-system)))
      (build-system
       (name name)
       (description desc)
       (lower
        (lambda args
          (apply lower*
                 (if (memq #:install-plan args)
                     args
                     (append
                      args
                      (list
                       #:install-plan
                       `'(("." ,(string-append dir "/"))))))))))))

(define-public portable-r7rs-build-system
  (default-copying-build-system 'r7rs
                                "Copy Scheme libraries into R7RS directory"
                                r7rs-lib-dir))

(define-public portable-r6rs-build-system
  (default-copying-build-system 'r6rs
                                "Copy Scheme libraries into R6RS directory"
                                r6rs-lib-dir))

(define-public hello-world-r7rs
  (package
    (name "hello-world-r7rs")
    (version "1.0.0")
    (synopsis "Prints hello world")
    (description "A test library for packages that respect R7RS_LIBRARY_PATH")
    (license public-domain)
    (home-page "https://example.com")
    (build-system trivial-build-system)
    (source #f)
    (arguments
      `(#:modules ((guix build utils))
        #:builder
        (begin
          (use-modules (guix build utils))
          (let ((dir (string-append (assoc-ref %outputs "out") "/" ,r7rs-lib-dir)))
            (mkdir-p dir)
            (with-output-to-file (string-append dir "/hello-world.sld")
              (lambda () (write '(define-library (hello-world)
                                   (import (scheme base) (scheme write))
                                   (export hello-world)
                                   (begin (define (hello-world)
                                            (display "hello, r7rs")
                                            (newline)))))))))))))

(define-public hello-world-r6rs
  (package
    (name "hello-world-r6rs")
    (version "1.0.0")
    (synopsis "Prints hello world")
    (description "A test library for packages that respect R6RS_LIBRARY_PATH")
    (license public-domain)
    (home-page "https://example.com")
    (build-system trivial-build-system)
    (source #f)
    (arguments
      `(#:modules ((guix build utils))
        #:builder
        (begin
          (use-modules (guix build utils))
          (let ((dir (string-append (assoc-ref %outputs "out") "/" ,r6rs-lib-dir)))
            (mkdir-p dir)
            (with-output-to-file (string-append dir "/hello-world.sls")
              (lambda () (write '(library (hello-world)
                                   (export hello-world)
                                   (import (rnrs (6)))
                                   (define (hello-world)
                                     (display "hello, r6rs")
                                     (newline))))))))))))

(define-public r7rs-search-path-specification 
  (search-path-specification
    (variable "R7RS_LIBRARY_PATH")
    (files (list r7rs-lib-dir))))

(define-public r6rs-search-path-specification 
  (search-path-specification
    (variable "R6RS_LIBRARY_PATH")
    (files (list r6rs-lib-dir))))

(define (append-to name . variables)
  (define the-variables
    (let loop ((variables variables)
               (string ""))
      (if (null? variables)
          string
          (loop (cdr variables)
                (string-append string "\"$" (car variables) "\" ")))))
  (format #f
          "for s in ~a ; do
             if [ -n \"$s\" ]; then
               if [ -n \"$~a\" ]; then
                 export ~a+=\":\"
               fi
               export ~a+=\"$s\"
             fi
           done" the-variables name name name))

(define (splicing-path-component name)
  (format #f "${~a:+${~a}:}" name name))

(define (package/path imported-package
                      package-name
                      synopsis
                      description
                      binary-name
                      target-binary-name
                      guix-impl-envar
                      extra-path-specifications
                      libdir
                      generator-script)
(package
  (name (string-append package-name "-with-path"))
  (synopsis synopsis)
  (description description)
  (version "1.0.0")
  (source #f)
  (license gpl3+)
  (build-system trivial-build-system)
  (home-page "https://florida.moe/guix-scheme")
  (arguments
    `(#:modules ((guix build utils))
      #:builder
      (begin
        (use-modules (guix build utils))
        (let* ((bin (assoc-ref %outputs "out"))
               (impl (string-append
                       (assoc-ref %build-inputs ,package-name)
                       ,binary-name))
               (sh (string-append
                    (assoc-ref %build-inputs "bash-minimal")
                    "/bin/bash"))
               (script (string-append bin ,target-binary-name)))
          (mkdir-p (dirname script))
          (with-output-to-file script
            (lambda ()
              (,generator-script sh impl)))
          (chmod script #o755)))))
  (inputs (list imported-package bash-minimal))
  (native-inputs (list imported-package bash-minimal))
  (native-search-paths (cons (search-path-specification
                               (variable guix-impl-envar)
                               (files (list libdir)))
                             extra-path-specifications))))

;;;;;;;;;;;;;;
;;;; Foment
;;;;;;;;;;;;;;

(define-public foment-lib-dir "share/foment")
(define-public foment-build-system
  (default-copying-build-system 'foment-scheme
                                "Copy Scheme libraries into Foment Scheme directory"
                                foment-lib-dir))

(define-public foment
  (package
    (name "foment")
    (version "0.4.1-1.6089c3c")
    (source
      (origin
         (method git-fetch)
         (uri (git-reference (url "https://github.com/leftmike/foment")
                             (commit "6089c3c9e762875f619ef382d27943819bbe002b")))
         (sha256 (base32 "1a6q8qfd6ggc6fl9lf1d8m20q8k498jrswc4qcn3bb7rkq4w258a"))))
    (build-system gnu-build-system)
    (arguments 
      (list
       #:phases
        #~(modify-phases %standard-phases
            (delete 'configure)
            (add-before 'build 'patch-makefile
              (lambda* (#:key outputs #:allow-other-keys)
                (substitute* "unix/makefile"
                  (("sudo *") "")
                  (("git rev-parse --abbrev-ref HEAD") "echo \"master\"")
                  (("git rev-parse --short HEAD") "echo 6089c3c"))
;; Replace hardcoded path /bin/sh with the current interpreter.
;; This follows what racket does:
;; https://issues.guix.gnu.org/47180
                (substitute* "src/base.scm"
                  (("\"/bin/sh\"")
                   (let ((sh (which "sh")))
                     (string-append "(if (file-exists? \"" sh "\")\n"
                                    "    \"" sh "\"\n" 
                                    "    \"/bin/sh\")"))))))
            (replace 'build
              (lambda _
                (with-directory-excursion "unix"
                  (invoke "make"))))
            (replace 'check
              (lambda* (#:key tests? #:allow-other-keys)
                (when tests?
                  (with-directory-excursion "unix"
                    (invoke "make" "test")
                    (invoke "make" "stress-test")))))
            (replace 'install
              (lambda* (#:key outputs #:allow-other-keys)
                 (let ((bin (string-append (assoc-ref outputs "out")
                                           "/bin")))
                 (install-file "unix/release/foment" bin)
                 (copy-recursively "unix/debug/foment"
                                   (string-append bin "/foment-debug"))))))))
    (home-page "https://github.com/leftmike/foment")
    (synopsis "Foment is an implementation of R7RS Scheme.")
    (license expat)
    (inputs '())
    (native-inputs (list bash))
    (description "Foment is an implementation of R7RS Scheme written in C++ with support for continuation marks and many SRFIs.")))

(define-public foment-with-path
  (package/path foment
                "foment"
                "Foment with Guix paths"
                "Wrapper for Foment Scheme that adds Guix-managed paths to Foment search path"
                "/bin/foment"
                "/bin/foment"
                "GUIX_FOMENT_PATH"
                (list r7rs-search-path-specification)
                foment-lib-dir
                `(lambda (sh impl)
                   (format #t
                    "#!~a

                     ~a
                     exec -a $0 \"~a\" \"$@\""
                    sh
                    ,(append-to "FOMENT_LIBPATH" "GUIX_FOMENT_PATH" "R7RS_LIBRARY_PATH")
                    impl))))

;;;;;;;;;;;;;;;;;;;
;;;; Chibi
;;;;;;;;;;;;;;;;;;;

(define-public chibi-lib-dir "share/guix-chibi")
(define-public chibi-binlib-dir "lib/guix-chibi")

(define-public chibi-scheme-build-system
  (default-copying-build-system 'chibi-scheme
                                "Copy Scheme libraries into Chibi Scheme directory"
                                foment-lib-dir))

(define-public chibi-scheme-with-path
  (package/path
   chibi-scheme
   "chibi-scheme"
   "Chibi Scheme with Guix paths"
   "Wrapper for Chibi Scheme that adds Guix-managed paths to search path"
   "/bin/chibi-scheme"
   "/bin/chibi-scheme"
   "GUIX_CHIBI_PATH"
   (list r7rs-search-path-specification)
   chibi-lib-dir
   `(lambda (sh impl)
      (format #t
       "#!~a

        ~a
        if [ -z \"$CHIBI_MODULE_PATH\" ]; then
            export CHIBI_MODULE_PATH=\".:./lib\"
        fi

        exec -a $0 \"~a\" \"$@\""
       sh 
       ,(append-to "CHIBI_MODULE_PATH" "GUIX_CHIBI_PATH" "R7RS_LIBRARY_PATH")
       impl))))

;;;;;;;;;;;;;;;;
;;;; Sagittarius
;;;;;;;;;;;;;;;;

(define-public sagittarius-lib-dir "share/guix-sagittarius")

(define-public sagittarius-scheme-build-system
  (default-copying-build-system 'sagittarius
                                "Copy Scheme libraries into Sagittarius directory"
                                foment-lib-dir))

(define-public sagittarius-scheme
  (package
    (name "sagittarius-scheme")
    (version "0.9.13")
    (source
      (origin
         (method url-fetch)
         (uri "https://github.com/ktakashi/sagittarius-scheme/releases/download/v0.9.13/sagittarius-0.9.13.tar.gz")
         (sha256 (base32 "0wspsv7mr1lchv0lfc50s750a358534pgri1c2fqlws31hci5y4c"))))
    (build-system cmake-build-system)
    (arguments '(#:phases (modify-phases %standard-phases
                            ;; Tests don't work yet. Issues with network.
                            (delete 'check))))
    (inputs (list libgc zlib libffi openssl))
    (home-page "https://ktakashi.github.io/")
    (synopsis "Script interpreter with many built-in libraries")
    (license bsd-2)
    (description "Sagittarius Scheme is a R6RS/R7RS Scheme implementation with a lot of practical libraries, especially cryptographic libraries.")))

(define-public sagittarius-scheme-with-path
  (package/path sagittarius-scheme
                "sagittarius-scheme"
                "Sagittarius Scheme with Guix paths"
                "Wrapper for Sagittarius Scheme that adds Guix-managed paths"
                "/bin/sagittarius"
                "/bin/sagittarius"
                "GUIX_SAGITTARIUS_PATH"
                (list r6rs-search-path-specification r7rs-search-path-specification)
                foment-lib-dir
                `(lambda (sh impl)
                   (format #t
                    "#!~a

                     ~a
                     exec -a $0 \"~a\" \"$@\""
                    sh
                    ,(append-to "SAGITTARIUS_LOADPATH" "GUIX_SAGITTARIUS_PATH" "R6RS_LIBRARY_PATH" "R7RS_LIBRARY_PATH")
                    impl))))

;;;;;;;;;;;;;;;;;;
;;;; Gauche
;;;;;;;;;;;;;;;;;;

(define (generate-gauche-library-information package)
  (define gauche-abi-version
    (let* ((version (string-split (package-version gauche) #\.))
           (major (string->number (car version)))
           (minor (string->number (list-ref version 1)))
           (patch (string->number (list-ref version 2))))
      (cond
        ((and (= major 0) (= minor 9) (= patch 10))
         "0.97")
        ((and (= major 0) (= minor 9) (> patch 11))
         "0.98")
        (else (error 'gauche-abi-version "unknown gauche version: patch me!"
                     major minor patch)))))
  (values gauche-abi-version
          (string-append "share/gauche-" gauche-abi-version "/site/lib")
          (string-append "lib/gauche-" gauche-abi-version "/site/x86_64-unknown-linux-gnu")))

(define-public gauche-build-system
  (let-values (((_1 dir _2) (generate-gauche-library-information gauche)))
    (default-copying-build-system 'gauche
                                  "Library for pure Scheme gauche libraries"
                                  dir)))

(define-public gauche-with-path
  (let-values (((abi-ver libpath dynlibpath) (generate-gauche-library-information gauche)))
   (package/path gauche
                "gauche"
                "Gauche with Guix paths"
                "Wrapper for Gauche that adds Guix-managed paths"
                "/bin/gosh"
                "/bin/gosh"
                "GUIX_GAUCHE_PATH"
                (list (search-path-specification
                        (variable "GUIX_GAUCHE_DYN_PATH")
                        (files (list dynlibpath)))
                      r7rs-search-path-specification)
                libpath
                `(lambda (sh impl)
                   (format #t
                    "#!~a

                     ~a
                     ~a
                     exec -a $0 \"~a\" \"$@\""
                    sh
                    ,(append-to "GAUCHE_LOAD_PATH" "GUIX_GAUCHE_PATH" "R7RS_LIBRARY_PATH")
                    ,(append-to "GAUCHE_DYNLOAD_PATH" "GUIX_GAUCHE_DYN_PATH")
                    impl)))))

;;;;;;;;;;
;;;; Loko
;;;;;;;;;;

(define-public loko-scheme-lib-dir "share/loko")

(define-public loko-scheme-build-system
  (default-copying-build-system 'loko
                                "Copy Scheme libraries into Loko directory"
                                loko-scheme-lib-dir))

(define-public loko-scheme-with-path
  (package/path loko-scheme
                "loko-scheme"
                "Loko Scheme with Guix paths"
                "Wrapper for Loko that adds Guix-managed paths"
                "/bin/loko"
                "/bin/loko"
                "GUIX_LOKO_PATH"
                (list r6rs-search-path-specification r7rs-search-path-specification)
                loko-scheme-lib-dir
                `(lambda (sh impl)
                   (format #t
                    "#!~a

                     ~a
                     exec -a $0 \"~a\" \"$@\""
                    sh
                    ,(append-to "LOKO_LIBRARY_PATH" "GUIX_LOKO_PATH" "R6RS_LIBRARY_PATH" "R7RS_LIBRARY_PATH")
                    impl))))

;;;;;;;;;;;;;;;;;;;
;;;; STKlos
;;;;;;;;;;;;;;;;;;;

(define-public stklos-lib-dir "share/stklos")

(define-public stklos-build-system
  (default-copying-build-system 'stklos
                                "Copy Scheme libraries into STKlos directory"
                                stklos-lib-dir))

(define-public stklos-with-path
  (package/path
   stklos
   "stklos"
   "STKlos with Guix paths"
   "Wrapper for STKlos that adds Guix-managed paths to search path"
   "/bin/stklos"
   "/bin/stklos"
   "GUIX_STKLOS_PATH"
   (list r7rs-search-path-specification)
   stklos-lib-dir
   `(lambda (sh impl)
      (format #t
       "#!~a

        ~a

        exec -a $0 \"~a\" \"$@\""
       sh 
       ,(append-to "STKLOS_LOAD_PATH" "GUIX_STKLOS_PATH" "R7RS_LIBRARY_PATH")
       impl))))

;;;;;;;;;;;
;;;; TR7
;;;;;;;;;;;

(define-public tr7
  ;; Current guix TR7 is a major version out of date
  (package
    (name "tr7")
    (version "2.0.6")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://gitlab.com/jobol/tr7")
             (commit (string-append "v" version))))
       (sha256
        (base32 "0z9zjk71294afr5aynnr8q9iih6q6lfsx747swbaz14r5vpjhg3n"))
       (file-name (git-file-name name version))))
    (build-system gnu-build-system)
    (outputs '("out" "doc"))
    (arguments
     (list
      #:phases
      #~(modify-phases %standard-phases
          (replace 'configure
            (lambda _
              (substitute* "Makefile"
                (("PREFIX = /usr/local")
                 (string-append "PREFIX=" #$output))
                (("ALL = \\$\\(LIBSTA\\) \\$\\(TR7I\\) tags")
                 "ALL = $(LIBSTA) $(TR7I)"))))
          (replace 'build
            (lambda _
              (setenv "CC" #$(cc-for-target))
              (invoke "make")))
          (replace 'check
            (lambda* (#:key tests? #:allow-other-keys)
              (when tests?
                (invoke "make" "test"))))
          (replace 'install
            (lambda _
              (let* ((share (string-append #$output "/share"))
                     (doc (string-append #$output:doc "/share/doc/"))
                     (bin (string-append #$output "/bin"))
                     (lib (string-append #$output "/lib/"))
                     (tr7 (string-append share "/tr7"))
                     (libs (string-append tr7 "/libs")))
                (for-each mkdir-p (list tr7 libs bin lib doc))
                (copy-file "tr7i" (string-append bin "/tr7i"))
                (copy-file "libtr7.a" (string-append lib "/libtr7.a"))
                #;(copy-file "r7rs.pdf" (string-append doc "/r7rs.pdf"))
                (copy-recursively "tr7libs" libs)))))))
    (home-page "https://gitlab.com/jobol/tr7")
    (synopsis "Embedded R7RS small Scheme interpreter")
    (description
     "TR7 is a lightweight Scheme interpreter that implements the revision
R7RS small of scheme programming language.

It is meant to be used as an embedded scripting interpreter for other
programs.  A lot of functionality in TR7 is included conditionally, to allow
developers freedom in balancing features and footprint.")
    (license bsd-0)))

(define-public tr7-lib-dir "share/tr7")

(define-public tr7-build-system
  (default-copying-build-system 'tr7
                                "Copy Scheme libraries into TR7 directory"
                                tr7-lib-dir))

(define-public tr7-with-path
  (package/path
   tr7
   "tr7"
   "TR7 interpreter with Guix paths"
   "Wrapper for TR7 interpreter that adds Guix-managed paths to search path"
   "/bin/tr7i"
   "/bin/tr7i"
   "GUIX_TR7_PATH"
   (list r7rs-search-path-specification)
   tr7-lib-dir
   `(lambda (sh impl)
      (format #t
       "#!~a

        ~a

        exec -a $0 \"~a\" \"$@\""
       sh 
       ,(append-to "TR7_LIB_PATH" "GUIX_TR7_PATH" "R7RS_LIBRARY_PATH")
       impl))))

;;;;;;;;;;;;;;;;
;;;; Mosh
;;;;;;;;;;;;;;;;

(define-public mosh-lib-dir "share/mosh")

(define-public mosh-build-system
  (default-copying-build-system 'mosh
                                "Copy Scheme libraries into Mosh directory"
                                foment-lib-dir))

(define-public mosh-scheme
  (package
    (name "mosh-scheme")
    (version "0.2.9-rc1")
    (source
      (origin
         (method url-fetch)
         (uri "https://github.com/higepon/mosh/releases/download/mosh-0.2.9-rc1/mosh-0.2.9-rc1.tar.gz")
         (patches (search-patches "mcgoron/guix/patches/mosh-0.2.9-rc1-fix-ffitest.patch"))
         (sha256 (base32 "07w49dbhy3zgn9kq8lqwshjy66plpjkb9dv20sczkqr8w4vbs4cz"))))
    (build-system gnu-build-system)
    #;(arguments '(#:phases (modify-phases %standard-phases
                            ;; Tests don't work yet. Issues with network.
                            (add-before 'check 'remove-broken-tests
                              (lambda _ )))))
    (inputs (list oniguruma gmp openssl))
    (home-page "https://mosh.monaos.org")
    (synopsis "Free and fast R6RS interpreter")
    (license bsd-2)
    (description "Mosh is a free and fast interpreter for Scheme as specified in the R7RS & R6RS.  (R7RS is the latest revision of the Scheme standard)

The current release of Mosh supports all of the features R7RS small and R6RS.")))

(define-public mosh-scheme-with-path
  (package/path mosh-scheme
                "mosh-scheme"
                "Mosh with Guix paths"
                "Wrapper for Mosh that adds Guix-managed paths"
                "/bin/mosh"
                "/bin/mosh"
                "GUIX_MOSH_PATH"
                (list r6rs-search-path-specification)
                mosh-lib-dir
                `(lambda (sh impl)
                   (format #t
                    "#!~a

                     ~a
                     exec -a $0 \"~a\" \"$@\""
                    sh
                    ,(append-to "MOSH_LOADPATH" "GUIX_MOSH_PATH" "R6RS_LIBRARY_PATH")
                    impl))))