#| 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 srfi)
  #: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 (guix build-system gnu)
  #:use-module (guix build-system)
  #:use-module (guix build-system copy)
  #:use-module (guix build-system trivial)
  #:use-module (guix build-system cmake)
  #:use-module (mcgoron guix scheme-packages)
  #:use-module (guix gexp))

(define srfi-1-exports
  '(xcons make-list list-tabulate cons* list-copy
          proper-list? circular-list? dotted-list? not-pair? null-list? list=
          circular-list length+
          iota
          first second third fourth fifth sixth seventh eighth ninth tenth
          car+cdr
          take drop
          take-right drop-right
          take! drop-right!
          split-at split-at!
          last last-pair
          zip unzip1 unzip2 unzip3 unzip4 unzip5
          count
          append! append-reverse append-reverse! concatenate concatenate!
          unfold fold pair-fold reduce
          unfold-right fold-right pair-fold-right reduce-right
          append-map append-map! map! pair-for-each filter-map map-in-order
          filter partition remove
          filter! partition! remove!
          find find-tail any every list-index
          take-while drop-while take-while!
          span break span! break!
          delete delete!
          alist-cons alist-copy
          delete-duplicates delete-duplicates!
          alist-delete alist-delete!
          reverse!
          lset<= lset= lset-adjoin
          lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
          lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
          map for-each member assoc))

(define srfi-1-special-forms
  ''(begin
      (define-syntax :optional
        (syntax-rules ()
          ((_ x y) (if (null? x) y (car x)))))
      (define (for-each f l1 . l-rest)
        (let loop ((lists (cons l1 l-rest)))
          (receive (cars cdrs) (%cars+cdrs lists)
            (if (pair? cars)
                (begin
                  (apply f cars)
                  (loop cdrs))))))))

(define (output-literal-form form lib-dir filename)
  (list #:modules '((guix build utils))
        #:builder
        #~ (begin
             (use-modules (guix build utils))
             (let ((dir (string-append (assoc-ref %outputs "out")
                                       "/"
                                       #$lib-dir)))
               (mkdir-p dir)
               (with-output-to-file (string-append dir "/" #$filename)
                 (lambda () (write ' #$form)))))))

(define-public srfi-8-r7rs
  (package
   (name "srfi-8-r7rs")
   (version "final")
   (build-system trivial-build-system)
   (home-page "https://srfi.schemers.org/srfi-8/srfi-8.html")
   (synopsis "receive: Binding to multiple values (R7RS)")
   (source #f)
   (license expat)
   (inputs '())
   (description "The syntax proposed in this SRFI is used in the reference implementation of SRFI-1, “List library.”")
   (arguments (output-literal-form
               '(define-library (srfi 8)
                  (import (scheme base))
                  (export receive)
                  (begin
                    (define-syntax receive
                      (syntax-rules ()
                        ((receive formals expression body ...)
                         (let-values ((formals expression))
                           body ...))))))
               (string-append r7rs-lib-dir "/srfi")
               "8.sld"))))

(define-public srfi-8-r6rs
  (package
   (name "srfi-8-r6rs")
   (source #f)
   (version "final")
   (build-system trivial-build-system)
   (home-page "https://srfi.schemers.org/srfi-8/srfi-8.html")
   (synopsis "receive: Binding to multiple values (R6RS)")
   (license expat)
   (inputs '())
   (description "The syntax proposed in this SRFI is used in the reference implementation of SRFI-1, “List library.”")
   (arguments (output-literal-form
               '(library (srfi :8)
                  (import (rnrs base))
                  (export receive)
                  (begin
                    (define-syntax receive
                      (syntax-rules ()
                        ((receive formals expression body ...)
                         (let-values ((formals expression))
                           body ...))))))
               (string-append r6rs-lib-dir "/srfi")
               ":8.sls"))))

(define-public srfi-227-r7rs
  (package
   (name "srfi-227-r7rs")
   (version "final")
   (source (origin (method git-fetch)
                   (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-227")
                                       (commit "final")))
                   (sha256 (base32 "1325az0zmxxmkdvpz24v2nikp3dr1ihgyqcl55my61rwjpgcwjhl"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-227")
   (synopsis "Optional Arguments (R7RS)")
   (license expat)
   (inputs '())
   (description
    "This SRFI specifies the opt-lambda syntax, which generalizes lambda. An opt-lambda expression evaluates to a procedure that takes a number of required and a number of optional (positional) arguments whose default values are determined by evaluating corresponding expressions when the procedure is called.

This SRFI also specifies a variation opt*-lambda, which is to opt-lambda as let* is to let and the related binding constructs let-optionals and let-optionals*.

Finally, for those who prefer less explicit procedure definitions, a sublibrary provides define-optionals and define-optionals*.")
   (arguments
    (list
     #:install-plan
     `(("lib/srfi/" ,(string-append r7rs-lib-dir "/srfi/")
        #:include (".sld" ".scm")))))))

(define-public srfi-227-r6rs
  (package
   (name "srfi-227-r6rs")
   (version "final")
   (source (origin (method git-fetch)
                   (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-227")
                                       (commit "final")))
                   (sha256 (base32 "1325az0zmxxmkdvpz24v2nikp3dr1ihgyqcl55my61rwjpgcwjhl"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-227")
   (synopsis "Optional Arguments (R6RS)")
   (license expat)
   (inputs '())
   (description
    "This SRFI specifies the opt-lambda syntax, which generalizes lambda. An opt-lambda expression evaluates to a procedure that takes a number of required and a number of optional (positional) arguments whose default values are determined by evaluating corresponding expressions when the procedure is called.

This SRFI also specifies a variation opt*-lambda, which is to opt-lambda as let* is to let and the related binding constructs let-optionals and let-optionals*.

Finally, for those who prefer less explicit procedure definitions, a sublibrary provides define-optionals and define-optionals*.")
   (arguments
    (list
     #:install-plan
     `'(("lib/srfi/" ,(string-append r7rs-lib-dir "/srfi/")
         #:include (".sls")))))))

(define-public srfi-1-r7rs
  (package
   (name "srfi-1-r7rs")
   (version "errata-7")
   (source
    (origin (method git-fetch)
            (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-1")
                                (commit "errata-7")))
            (sha256 (base32 "18lj5y85zxs0yzkdv66qd290nwms7jy27ky1x3ba9kp6hzjia5kj"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-1")
   (synopsis "List library (R7RS)")
   (license (non-copyleft "https://srfi.schemers.org/srfi-1/srfi-1.html"))
   (inputs '())
   (description " R5RS Scheme has an impoverished set of list-processing utilities, which is a problem for authors of portable code. This SRFI proposes a coherent and comprehensive set of list-processing procedures; it is accompanied by a reference implementation of the spec. The reference implementation is

    portable
    efficient
    completely open, public-domain source
")
   (arguments
    (list
     #:imported-modules `(,@%copy-build-system-modules (mcgoron guix srfi-util))
     #:phases
     #~ (modify-phases %standard-phases
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (use-modules (mcgoron guix srfi-util))
              (let ((lib (string-append (assoc-ref %outputs "out")
                                        "/" #$r7rs-lib-dir
                                        "/srfi")))
                (mkdir-p lib)
                (splice-files (string-append lib "/1.sld")
                              7
                              '(srfi 1)
                              '#$srfi-1-exports
                              '((scheme base)
                                (scheme cxr)
                                (scheme case-lambda)
                                (srfi 8) (srfi 227))
                              '(define-syntax check-arg
                                 (syntax-rules ()
                                   ((_ pred val caller)
                                    (let ((tmp val))
                                      (if (pred val)
                                          val
                                          (error "Bad argument" 'pred
                                                 tmp
                                                 'caller))))))
                              #$srfi-1-special-forms
                              "srfi-1-reference.scm")))))))))

(define-public srfi-1-r6rs
  (package
   (name "srfi-1-r6rs")
   (version "errata-7")
   (source
    (origin (method git-fetch)
            (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-1")
                                (commit "errata-7")))
            (sha256 (base32 "18lj5y85zxs0yzkdv66qd290nwms7jy27ky1x3ba9kp6hzjia5kj"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-1")
   (synopsis "List library (R6RS)")
   (license (non-copyleft "//srfi.schemers.org/srfi-1/srfi-1.html"))
   (inputs (list srfi-8-r6rs srfi-227-r6rs))
   (native-inputs '())
   (description " R5RS Scheme has an impoverished set of list-processing utilities, which is a problem for authors of portable code. This SRFI proposes a coherent and comprehensive set of list-processing procedures; it is accompanied by a reference implementation of the spec. The reference implementation is

    portable
    efficient
    completely open, public-domain source
")
   (arguments
    (list
     #:imported-modules `(,@%copy-build-system-modules (mcgoron guix srfi-util))
     #:phases
     #~ (modify-phases %standard-phases
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (use-modules (mcgoron guix srfi-util))
              (let ((lib (string-append (assoc-ref %outputs "out")
                                        "/" #$r6rs-lib-dir
                                        "/srfi")))
                (mkdir-p lib)
                (splice-files (string-append lib "/:1.sls")
                              6
                              '(srfi :1)
                              '#$srfi-1-exports
                              '((except (rename (rnrs base) (error %error))
                                        map
                                        for-each)
                                (rnrs control)
                                (except (rnrs lists) remove find partition filter fold-right cons* member assoc)
                                (rnrs mutable-pairs) (rnrs r5rs)
                                (srfi :8) (srfi :227))
                              '(define-syntax check-arg
                                 (syntax-rules ()
                                   ((_ pred val caller)
                                    (let ((tmp val))
                                      (if (pred val)
                                          val
                                          (assertion-violation
                                           'caller
                                           "invalid argument"
                                           val
                                           'pred))))))
                              '(define (error msg . irritants)
                                 (apply %error #f msg irritants))
                              #$srfi-1-special-forms
                              "srfi-1-reference.scm")))))))))

(define-public srfi-128-r7rs
  (package
   (name "srfi-128-r7rs")
   (version "errata-4")
   (source
    (origin (method git-fetch)
            (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-128")
                                (commit "errata-4")))
            (sha256 (base32 "1jlradj1m28m0gcl8dj1p7hydzvf151ylgyicv9k20xm8l5damks"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-128")
   (synopsis "Comparators (reduced) (R7RS)")
   (license expat)
   (inputs '())
   (native-inputs '())
   (description
    "This SRFI provides comparators, which bundle a type test predicate, an equality predicate, an ordering predicate, and a hash function (the last two are optional) into a single Scheme object. By packaging these procedures together, they can be treated as a single item for use in the implementation of data structures. ")
   (arguments
    (list
     #:phases
     #~ (modify-phases %standard-phases
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (let ((lib (string-append (assoc-ref %outputs "out")
                                        "/" #$r7rs-lib-dir
                                        "/srfi")))
                (mkdir-p lib)
                (copy-recursively "srfi" lib)))))))))

(define-public srfi-9-r6rs
  (package
   (name "srfi-9-r6rs")
   (source #f)
   (version "final")
   (synopsis "Defining Record Types (R6RS)")
   (description "This SRFI describes syntax for creating new data types, called record types. A predicate, constructor, and field accessors and modifiers are defined for each record type. Each new record type is distinct from all existing types, including other record types and Scheme's predefined types.")
   (home-page "https://github.com/arcfide/chez-srfi")
   (build-system trivial-build-system)
   (license expat)
   (inputs '())
   (native-inputs '())
   (arguments
    (output-literal-form
     '(library (srfi :9)
        (export (rename (my:define-record-type define-record-type)))
        (import (rnrs))
        (define-syntax my:define-record-type
          (lambda (stx)
            (syntax-case stx ()
              ((_ type (constructor constructor-tag ...)
                  predicate
                  (field-tag accessor setter ...) ...)
               (and (for-all identifier?
                             #'(type constructor constructor-tag ... predicate
                                     field-tag ... accessor ... setter ... ...))
                    (for-all (lambda (s) (<= 0 (length s) 1))
                             #'((setter ...) ...))
                    (for-all (lambda (ct)
                               (memp (lambda (ft) (bound-identifier=? ct ft))
                                     #'(field-tag ...)))
                             #'(constructor-tag ...)))
               (with-syntax (((field-clause ...)
                              (map (lambda (clause)
                                     (if (= 2 (length clause))
                                         #`(immutable . #,clause)
                                         #`(mutable . #,clause)))
                                   #'((field-tag accessor setter ...) ...)))
                             ((unspec-tag ...)
                              (remp (lambda (ft)
                                      (memp (lambda (ct) (bound-identifier=? ft ct))
                                            #'(constructor-tag ...)))
                                    #'(field-tag ...))))
                 #'(define-record-type (type constructor predicate)
                     (protocol (lambda (ctor)
                                 (lambda (constructor-tag ...)
                                   (define unspec-tag) ...
                                   (ctor field-tag ...))))
                     (fields field-clause ...))))))))
     (string-append r6rs-lib-dir "/srfi/")
     ":9.sls"))))

(define-public compatible-parameters-chez
  (package
   (name "compatible-parameters-chez")
   (version "1.0.0")
   (source #f)
   (build-system trivial-build-system)
   (license unlicense)
   (home-page "https://florida.moe")
   (synopsis "Shim library for parameters (Chez)")
   (description "Shim library for parameters, mutable or immutable.")
   (arguments
    (output-literal-form
     '(library (mcgoron compatible-parameters)
        (export make-parameter parameterize)
        (import (only (chezscheme) make-parameter parameterize)))
     (string-append chez-lib-dir "/mcgoron")
     "compatible-parameters.sls"))))

(define-public srfi-128-r6rs
  (package
   (name "srfi-128-r6rs")
   (version "errata-4")
   (source
    (origin (method git-fetch)
            (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-128")
                                (commit "errata-4")))
            (sha256 (base32 "1jlradj1m28m0gcl8dj1p7hydzvf151ylgyicv9k20xm8l5damks"))))
   (build-system copy-build-system)
   (home-page "https://srfi.schemers.org/srfi-128")
   (synopsis "Comparators (reduced) (R6RS)")
   (license expat)
   (inputs '())
   (description
    "This SRFI provides comparators, which bundle a type test predicate, an equality predicate, an ordering predicate, and a hash function (the last two are optional) into a single Scheme object. By packaging these procedures together, they can be treated as a single item for use in the implementation of data structures. ")
   (arguments
    (list
     #:imported-modules `(,@%copy-build-system-modules (mcgoron guix srfi-util))
     #:phases
     #~ (modify-phases %standard-phases
          (replace 'install
            (lambda* (#:key outputs #:allow-other-keys)
              (use-modules (mcgoron guix srfi-util))
              (let ((lib (string-append (assoc-ref %outputs "out")
                                        "/" #$r6rs-lib-dir
                                        "/srfi")))
                (mkdir-p lib)
                (splice-files (string-append lib "/:128.sls")
                              6
                              '(srfi :128)
                              '(comparator? comparator-ordered? comparator-hashable? make-comparator make-pair-comparator make-list-comparator make-vector-comparator make-eq-comparator make-eqv-comparator make-equal-comparator boolean-hash char-hash char-ci-hash string-hash string-ci-hash symbol-hash number-hash make-default-comparator default-hash comparator-register-default! comparator-type-test-predicate comparator-equality-predicate comparator-ordering-predicate comparator-hash-function comparator-test-type comparator-check-type comparator-hash hash-bound hash-salt =? <? >? <=? >=? comparator-if<=>)
                              '((except (rename (rnrs) (error %error))
                                        define-record-type
                                        string-hash
                                        string-ci-hash
                                        symbol-hash)
                                (rnrs r5rs)
                                (srfi :9)
                                (mcgoron compatible-parameters))
                              '(define (exact-integer? x)
                                 (and (exact? x) (integer? x)))
                              '(define (error msg . irritants)
                                 (%error #f msg irritants))
                              "srfi/128.body1.scm"
                              "srfi/128.body2.scm")))))))))