diff options
| -rw-r--r-- | .gitignore | 15 | ||||
| -rw-r--r-- | .reuse/dep5 | 4 | ||||
| -rw-r--r-- | LICENSES/CC0-1.0.txt | 121 | ||||
| -rw-r--r-- | Makefile.am | 13 | ||||
| -rw-r--r-- | README.md | 56 | ||||
| -rw-r--r-- | README.md.license | 3 | ||||
| -rw-r--r-- | autotools-aux/config.rpath | 0 | ||||
| -rwxr-xr-x | bootstrap | 8 | ||||
| -rw-r--r-- | configure.ac | 24 | ||||
| -rw-r--r-- | guix-devshell | 22 | ||||
| -rw-r--r-- | guix.scm | 13 | ||||
| -rw-r--r-- | src/guile/Makefile.am | 20 | ||||
| -rw-r--r-- | src/guile/de-paul-records.scm | 351 | ||||
| -rw-r--r-- | tests/guile/Makefile.am | 25 | ||||
| -rw-r--r-- | tests/guile/de-paul-records-test.scm | 229 |
15 files changed, 904 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..378c6c0 --- /dev/null +++ b/.gitignore @@ -0,0 +1,15 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +*.go +Makefile +Makefile.in +aclocal.m4 +autom4te.cache +autotools-aux +config.log +config.status +configure +configure~ +de-paul-records-*.tar.gz diff --git a/.reuse/dep5 b/.reuse/dep5 new file mode 100644 index 0000000..0220193 --- /dev/null +++ b/.reuse/dep5 @@ -0,0 +1,4 @@ +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: de Paul records +Upstream-Contact: Wojtek Kosior <koszko@koszko.org> +Source: https://git.koszko.org/de-paul-records/about diff --git a/LICENSES/CC0-1.0.txt b/LICENSES/CC0-1.0.txt new file mode 100644 index 0000000..0e259d4 --- /dev/null +++ b/LICENSES/CC0-1.0.txt @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..df2368c --- /dev/null +++ b/Makefile.am @@ -0,0 +1,13 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +SUBDIRS = src/guile tests/guile + +EXTRA_DIST = \ + LICENSES/CC0-1.0.txt \ + .reuse/dep5 \ + guix-devshell \ + bootstrap \ + .gitignore \ + README.md.license diff --git a/README.md b/README.md new file mode 100644 index 0000000..93f5a40 --- /dev/null +++ b/README.md @@ -0,0 +1,56 @@ +# de Paul records + +Software freedom empowers sharing. Let's dedicate our libre software projects +to saints known for fostering sharing! + +This Guile records library is dedicated to St. Vincent de Paul, a french priest +from 17th century who served the poor. Being a great organizer, he managed to +encourage even high-rank nobles to participate in charity work. Apparently, he +had more success than we have with encouraging state authorities to start caring +about digital freedom… + +## Why another records API? + +GNU Guile implements SRFI-9 which already provides a records API. Guile also +includes a GNU extension in `(srfi srfi-9 gnu)` which provides an API for purely +functional records. + +What these APIs lack is a nice syntax for record construction. The constructor +procedures they generate do — at the time of writing — only accept positional +arguments which makes their use error-prone. A solution would be to — for every +record type defined — define one "null" record object and then construct +subsequent records of this type by cloning and modifying that null record. + +This library builds upon @code{(srfi srfi-9 gnu)} to aid with this and also with +other tasks. Features include + +- automatic deriving of getter names from field names, +- automatic generation of record constructor macros, +- support for default field values, +- support for programmer-supplied record finalizer procedures, +- syntax for creation of a record object based on an existing one, +- optional automatic export of generated getters and other variables, +- and amended variants of `(ice-9 match)` forms with (unhygienic) record + matcher that allows fields to be matched **by name**. + +This library is inspired by the Guix records API but follows purely functional +approach. + +## Use examples + +Please look into the test suite in `tests/guile/`. + +## Building & installation + +This software has a Guix package definition in Wojtek's [personal +channel](https://git.koszko.org/guix/about). That can serve you as a point of +reference. + +## Copying + +The source code of this package is available under CC0 v1.0. The repository is +kept compliant with the [REUSE](https://reuse.software/) specification, version +3.0. + +Note that the uderlying GNU Guile language is covered by the GNU GPL and hence +any binary redistribution of *de Paul records* shall be covered by it as well. diff --git a/README.md.license b/README.md.license new file mode 100644 index 0000000..e54bf4d --- /dev/null +++ b/README.md.license @@ -0,0 +1,3 @@ +SPDX-License-Identifier: CC0-1.0 + +Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> diff --git a/autotools-aux/config.rpath b/autotools-aux/config.rpath new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/autotools-aux/config.rpath diff --git a/bootstrap b/bootstrap new file mode 100755 index 0000000..0040cd3 --- /dev/null +++ b/bootstrap @@ -0,0 +1,8 @@ +#!/bin/sh + +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +cd "$(dirname "$0")" +autoreconf --install diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..470e267 --- /dev/null +++ b/configure.ac @@ -0,0 +1,24 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +AC_INIT([de-paul-records], [0.1], [koszko@koszko.org]) + +AC_CONFIG_SRCDIR([src/guile/de-paul-records.scm]) + +m4_pattern_forbid([^GUILE_]) +m4_pattern_allow([^GUILE_PKG_ERRORS$]) + +GUILE_PKG([3.0]) +GUILE_PROGS + +AC_PATH_PROG([GUILE_TEST_DRIVER], [guile-test-driver]) + +AC_CONFIG_AUX_DIR([autotools-aux]) + +AM_INIT_AUTOMAKE([-Wall -Werror foreign]) + +AC_CONFIG_FILES([Makefile src/guile/Makefile tests/guile/Makefile]) +AX_ADD_GUILE_PRE_INST_ENV() + +AC_OUTPUT diff --git a/guix-devshell b/guix-devshell new file mode 100644 index 0000000..85d8c91 --- /dev/null +++ b/guix-devshell @@ -0,0 +1,22 @@ +#!/bin/sh + +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +set -eu + +SOURCE_DIR="$(cd "$(dirname "$0")" && pwd -P)" +GUIX_SCM="$SOURCE_DIR"/guix.scm + +EXTRA_PACKAGES="reuse texinfo man-db" + +if test 0 = "$#" +then : + printf 'guix shell -Df '\''%s'\'' %s\n' "$GUIX_SCM" "$EXTRA_PACKAGES" + guix shell -Df "$GUIX_SCM" $PACKAGES +else : + shift + printf 'guix shell -Df '\''%s'\'' %s -- %s\n' "$PACKAGES" "$*" + guix shell -Df "$GUIX_SCM" $PACKAGES -- "$@" +fi diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..663e291 --- /dev/null +++ b/guix.scm @@ -0,0 +1,13 @@ +;;; SPDX-License-Identifier: CC0-1.0 +;;; +;;; Copyright (C) Wojtek Kosior <koszko@koszko.org> + +(use-modules ((guix inferior) #:select (inferior-for-channels)) + ((guix channels) #:select (channel))) + +(define inferior + (inferior-for-channels (list (channel + (name 'guix) + (url "https://git.koszko.org/guix"))))) + +(car (lookup-inferior-packages inferior "guile-de-paul-records")) diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..743ce74 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,20 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +GUILE_SOURCE_FILES = \ + $(PACKAGE).scm + +GUILE_OBJECT_FILES = \ + $(GUILE_SOURCE_FILES:.scm=.go) + +gobjdir = $(libdir)/guile/@GUILE_EFFECTIVE_VERSION@/site-ccache +nobase_gobj_DATA = $(GUILE_OBJECT_FILES) + +scmdir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@ +nobase_dist_scm_DATA = $(GUILE_SOURCE_FILES) + +.scm.go: + $(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $< + +MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES) diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm new file mode 100644 index 0000000..57d65e5 --- /dev/null +++ b/src/guile/de-paul-records.scm @@ -0,0 +1,351 @@ +;;; SPDX-License-Identifier: CC0-1.0 +;;; +;;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +(define-module (de-paul-records) + #:use-module ((srfi srfi-1) #:select (append-map)) + #:use-module ((srfi srfi-9 gnu) + #:select (define-immutable-record-type set-field set-fields)) + #:use-module ((srfi srfi-26) #:select (cut)) + #:use-module ((ice-9 format) #:select (format)) + #:use-module ((ice-9 match) #:select (match match-lambda)) + #:use-module ((ice-9 match) #:prefix ice-9-match:) + #:re-export (set-field set-fields) + #:export ((match-override . match) + (match-lambda-override . match-lambda) + (match-lambda*-override . match-lambda*) + (match-let-override . match-let) + (match-let*-override . match-let*) + (match-letrec-override . match-letrec) + + define-immutable-record-type*)) + +(eval-when (compile load eval) + (define (get-first-identifier list-of-identifiers-and-other) + (let loop ((items list-of-identifiers-and-other)) + (match items + (() + (throw 'programming-error)) + (((? identifier? item) . _) + item) + ((_ . rest) + (loop rest))))) + + (define* (format-identifiers fmt #:rest args) + (let* ((first-identifier (get-first-identifier args)) + (processed-args (map (match-lambda + ((? identifier? identifier) + (symbol->string (syntax->datum identifier))) + (other + other)) + args)) + (formatted-string (apply format #f fmt processed-args))) + (datum->syntax first-identifier (string->symbol formatted-string)))) + + (define-immutable-record-type <field-spec> (make-field-spec) field-spec? + (name field-spec-name field-spec-set-name) + (default field-spec-default field-spec-set-default)) + + (define %null-field-spec + (set-field (make-field-spec) + (field-spec-default) #'#f)) + + (define (syntax->field-spec x) + (syntax-case x () + (field-name + (identifier? #'field-name) + (syntax->field-spec #'(field-name))) + ((field-name . field-args) + (let loop ((field-spec %null-field-spec) + (args #'field-args)) + (syntax-case args () + (() + (field-spec-set-name field-spec #'field-name)) + ((#:default default . args-rest) + (eq? (field-spec-default field-spec) + (field-spec-default %null-field-spec)) + (loop (field-spec-set-default field-spec #'default) + #'args-rest))))))) + + (define-immutable-record-type <record-spec> (make-record-spec) record-spec? + (name record-spec-name record-spec-set-name) + (fields record-spec-fields record-spec-set-fields) + (export? record-spec-export? record-spec-set-export?) + (finalize record-spec-finalize record-spec-set-finalize)) + + (define %null-record-spec + (set-fields (make-record-spec) + ((record-spec-fields) '()) + ((record-spec-export?) 'false-by-default))) + + (define (syntax->record-spec x) + (syntax-case x () + ((_ record-name . record-args) + (identifier? #'record-name) + (let loop ((record-spec %null-record-spec) + (args #'record-args)) + (syntax-case args () + (() + (set-fields record-spec + ((record-spec-name) #'record-name) + ((record-spec-fields) (reverse (record-spec-fields + record-spec))))) + ((#:export? export? . args-rest) + (eq? (record-spec-export? record-spec) 'false-by-default) + (loop (record-spec-set-export? record-spec + (and (syntax->datum #'export?) #t)) + #'args-rest)) + ((#:finalize finalizer . args-rest) + (not (record-spec-finalize record-spec)) + (loop (record-spec-set-finalize record-spec + #'finalizer) + #'args-rest)) + ((field-def . args-rest) + (loop (record-spec-set-fields record-spec + (cons (syntax->field-spec #'field-def) + (record-spec-fields record-spec))) + #'args-rest))))))) + + (define-immutable-record-type <field-init> (make-field-init) field-init? + (name field-init-name field-init-set-name) + (value-expr field-init-value-expr field-init-set-value-expr)) + + (define %null-field-init + (make-field-init)) + + (define (syntax->field-init x) + (syntax-case x () + ((field-name value-expr) + (identifier? #'field-name) + (set-fields %null-field-init + ((field-init-name) #'field-name) + ((field-init-value-expr) #'value-expr))) + (field-name + (identifier? #'field-name) + (syntax->field-init #'(field-name field-name))))) + + (define-immutable-record-type <record-init> (make-record-init) record-init? + (inherit record-init-inherit record-init-set-inherit) + (fields record-init-fields record-init-set-fields)) + + (define %null-record-init + (set-fields (make-record-init) + ((record-init-inherit) #f) + ((record-init-fields) '()))) + + (define (syntax->record-init x) + (syntax-case x () + ((_ . init-args) + (let loop ((record-init %null-record-init) + (args #'init-args)) + (syntax-case args () + (() + (set-field record-init + (record-init-fields) (reverse (record-init-fields record-init)))) + ((#:<- base . args-rest) + (not (record-init-inherit record-init)) + (loop (record-init-set-inherit record-init #'base) + #'args-rest)) + ((field-init . args-rest) + (loop (record-init-set-fields record-init + (cons (syntax->field-init #'field-init) + (record-init-fields record-init))) + #'args-rest))))))) + + (define (transform-record-init record-name %null-record init-form) + (match init-form + ((= syntax->record-init (and (= record-init-inherit inherit) + (= record-init-fields field-inits))) + #`(let* (#,@(map (match-lambda + ((and (= field-init-name field-name) + (= field-init-value-expr value-expr)) + #`(#,field-name #,value-expr))) + field-inits)) + (set-fields #,(or inherit %null-record) + #,@(map (match-lambda + ((= field-init-name field-name) + #`((#,(format-identifiers "~a-~a" + record-name field-name)) + #,field-name))) + field-inits)))))) + + (define-syntax define-immutable-record-type* + (match-lambda + ((= syntax->record-spec (and my-record-spec + (= record-spec-name record-name) + (= record-spec-fields field-specs) + (= record-spec-export? export?) + (= record-spec-finalize finalize))) + (with-syntax ((<record> (format-identifiers "<~a>" record-name)) + (--make-record (format-identifiers "--make-~a" + record-name)) + (record? (format-identifiers "~a?" record-name)) + (%null-record (format-identifiers "%null-~a" record-name)) + (*record (format-identifiers "*~a" record-name)) + (--finalize-record (format-identifiers "--finalize-~a" + record-name))) + #`(begin + (define-immutable-record-type <record> (--make-record) record? + #,@(map (match-lambda + ((= field-spec-name field-name) + #`(#,field-name + #,@(map (cut format-identifiers <> + record-name field-name) + '("~a-~a" "~a-set-~a"))))) + field-specs)) + + (define %null-record + (set-fields (--make-record) + #,@(map (match-lambda + ((and (= field-spec-name field-name) + (= field-spec-default default)) + #`((#,(format-identifiers "~a-~a" + record-name field-name)) + #,default))) + field-specs))) + + (define-syntax *record + (cut transform-record-init #'#,record-name #'%null-record <>)) + + (define --finalize-record + #,(or finalize #'identity)) + + (define-syntax-rule (#,record-name . body-rest) + (--finalize-record (*record . body-rest))) + + #,@(if (eq? export? #t) + (list + #`(export <record> #,record-name record? %null-record + #,@(append-map + (match-lambda + ((= field-spec-name field-name) + (map (cut format-identifiers <> + record-name field-name) + '("~a-~a" "~a-set-~a")))) + field-specs))) + #'())))))) + + (define (map-syntax proc syntax-list) + (syntax-case syntax-list () + (() + '()) + ((item . rest) + (cons (proc #'item) (map-syntax proc #'rest))))) + + (define (transform-match-field record-name-base field-form) + (syntax-case field-form () + (field-name + (identifier? #'field-name) + (transform-match-field record-name-base #'(field-name field-name))) + ((field-name pat pats ...) + (identifier? #'field-name) + (with-syntax ((record-field (format-identifiers "~a-~a" + record-name-base #'field-name))) + #`(= record-field + (and #,@(map-syntax transform-match-pat #'(pat pats ...)))))))) + + (define (transform-match-pat pat-form) + (syntax-case pat-form ($* = ? quote quasiquote) + ((quote something) + #'(quote something)) + ((quasiquote something) + #`(quasiquote #,(transform-quasiquoted-match-pat #'something))) + (#(pats ...) + (with-syntax (((pats* ...) #`(#,@(map-syntax transform-match-pat + #'(pats ...))))) + #'#(pats* ...))) + (($* record-name-base pats ...) + (identifier? #'record-name-base) + (with-syntax ((record? (format-identifiers "~a?" #'record-name-base))) + #`(? record? #,@(map-syntax (cut transform-match-field + #'record-name-base <>) + #'(pats ...))))) + ((= field pat) + #`(= field #,(transform-match-pat #'pat))) + ((? pred pats ...) + #`(? pred #,@(map-syntax transform-match-pat #'(pats ...)))) + ((head . tail) + #`(#,(transform-match-pat #'head) . #,(transform-match-pat #'tail))) + (other + #'other))) + + (define (transform-quasiquoted-match-pat pat-form) + (syntax-case pat-form (unquote unquote-splicing) + ((unquote something) + #`(unquote #,(transform-match-pat #'something))) + ((unquote-splicing something) + #`(unquote-splicing #,(transform-match-pat #'something))) + ((head . tail) + #`(#,(transform-quasiquoted-match-pat #'head) + . #,(transform-quasiquoted-match-pat #'tail))) + (#(pats ...) + (with-syntax (((pats* ...) #`(#,@(map-syntax + transform-quasiquoted-match-pat + #'(pats ...))))) + #'#(pats* ...))) + (other + #'other))) + + (define (transform-match-clauses clauses-forms) + #`(#,@(map-syntax (lambda (clause-form) + (syntax-case clause-form () + ((pat . body) + #`(#,(transform-match-pat #'pat) . body)))) + clauses-forms))) + + (define-syntax match-override + (lambda (x) + (syntax-case x () + ((_ expr . clauses) + #`(ice-9-match:match expr . #,(transform-match-clauses #'clauses)))))) + + (define-syntax match-lambda-override + (lambda (x) + (syntax-case x () + ((_ . clauses) + #`(ice-9-match:match-lambda + . #,(transform-match-clauses #'clauses)))))) + + (define-syntax match-lambda*-override + (lambda (x) + (syntax-case x () + ((_ . clauses) + #`(ice-9-match:match-lambda* + . #,(transform-match-clauses #'clauses)))))) + + (define transform-match-bindings + transform-match-clauses) + + (define-syntax match-let-override + (lambda (x) + (syntax-case x () + ((_ variable bindings . body) + (identifier? #'variable) + #`(ice-9-match:match-let variable + #,(transform-match-bindings #'bindings) + . body)) + ((_ bindings . body) + #`(ice-9-match:match-let #,(transform-match-bindings #'bindings) + . body))))) + + (define-syntax match-let*-override + (lambda (x) + (syntax-case x () + ((_ bindings . body) + #`(ice-9-match:match-let* #,(transform-match-bindings #'bindings) + . body))))) + + (define-syntax match-letrec-override + (lambda (x) + (syntax-case x () + ((_ bindings . body) + #`(ice-9-match:match-letrec #,(transform-match-bindings #'bindings) + . body)))))) + +;;; Local Variables: +;;; eval: (put 'format-identifiers 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-finalize 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-export? 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-fields 'scheme-indent-function 1) +;;; eval: (put 'record-init-set-fields 'scheme-indent-function 1) +;;; End: diff --git a/tests/guile/Makefile.am b/tests/guile/Makefile.am new file mode 100644 index 0000000..4dd1658 --- /dev/null +++ b/tests/guile/Makefile.am @@ -0,0 +1,25 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +GUILE_SOURCE_FILES = \ + $(PACKAGE)-test.scm + +GUILE_OBJECT_FILES = $(GUILE_SOURCE_FILES:.scm=.go) + + +TEST_EXTENSIONS = .scm + +SCM_LOG_DRIVER = $(top_builddir)/pre-inst-env $(GUILE_TEST_DRIVER) + +TESTS = $(GUILE_SOURCE_FILES) + + +dist_noinst_DATA = $(GUILE_SOURCE_FILES) + +check_DATA = $(GUILE_OBJECT_FILES) + +MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES) + +.scm.go: + $(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $< diff --git a/tests/guile/de-paul-records-test.scm b/tests/guile/de-paul-records-test.scm new file mode 100644 index 0000000..d8970a4 --- /dev/null +++ b/tests/guile/de-paul-records-test.scm @@ -0,0 +1,229 @@ +;;; SPDX-License-Identifier: CC0-1.0 +;;; +;;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +(use-modules ((srfi srfi-35) #:select (extract-condition condition-ref)) + ((ice-9 safe-r5rs) #:select (null-environment)) + ((srfi srfi-64) #:select (test-group)) + ((myra-test-utils) #:prefix tu:)) + +(define (make-env) + (let ((env (null-environment 5))) + (module-use! env (resolve-interface '(guile))) + env)) + +(define (test-env name) + (resolve-module `(de-paul-records-test ,name))) + +(test-group "exported record <lisp>" + (tu:test-assert + (or (eval '(begin + (define-module (de-paul-records-test lisp) + #:use-module ((de-paul-records))) + + (define-immutable-record-type* lisp + (name) + is-scheme? + #:export? yes,ofcourse + (is-syntactically-scoped? #:default #f) + #:finalize (lambda (the-lisp) + (set-field the-lisp + (lisp-is-syntactically-scoped?) + (or (lisp-is-syntactically-scoped? + the-lisp) + (lisp-is-scheme? the-lisp)))))) + (make-env)) + #t)) + + (tu:test-assert (macro? (module-ref (resolve-interface + '(de-paul-records-test lisp)) + 'lisp))) + + (tu:test-error (lambda (condition) + (let ((subcond (extract-condition + condition + &exception-with-kind-and-args))) + (eq? 'misc-error (condition-ref subcond 'kind)))) + (module-ref (resolve-interface + '(de-paul-records-test lisp)) + '*lisp)) + + (test-group "lisp paren-3001" + (tu:test-equal '(#f "paren-3001" #f) + (eval '(begin + (define %paren-3001 + (lisp (is-scheme? #f) + (name "paren-3001"))) + + (match %paren-3001 + (($* lisp + is-syntactically-scoped? + name + is-scheme?) + (list is-syntactically-scoped? + name + is-scheme?)))) + (test-env 'lisp))) + + (tu:test-equal '(iss? #f is? #f) + (eval '(match %paren-3001 + (($* lisp + (is-syntactically-scoped? iss?) + (name "paren-3001") + (is-scheme? is? $f)) + (list 'iss? iss? 'is? is?))) + (test-env 'lisp)))) + + (test-group "lisp paren-3002" + (tu:test-equal '#t + (eval + '(begin + (define %paren-3002 + (lisp #:<- %paren-3001 + (name "paren-3002") + (is-syntactically-scoped? #t))) + + (match `(a . ,%paren-3002) + (`(a . ,($* lisp is-syntactically-scoped?)) + is-syntactically-scoped?))) + (test-env 'lisp))) + + (tu:test-equal '(#f "paren-3002") + (eval + '(match (vector %paren-3002) + (#(($* lisp is-scheme? name)) + (list is-scheme? name))) + (test-env 'lisp)))) + + (test-group "lisp paren-3003" + (tu:test-equal '(#t #t) + (eval + '(begin + (define %paren-3003 + (let ((name "paren-3003")) + (lisp #:<- (lisp) + name + (is-scheme? (string-suffix? "-3003" name))))) + + (match %paren-3003 + (($* lisp is-scheme? is-syntactically-scoped?) + (list is-scheme? is-syntactically-scoped?)))) + (test-env 'lisp))) + + (tu:test-equal "paren-3003" + (eval '(lisp-name %paren-3003) + (test-env 'lisp)))) + + (test-group "lisp paren-3004" + (tu:test-equal '(#t #f) + (eval + '(begin + (define %paren-3004 + ;; (*lisp ...) form is a "primitive" variant of the + ;; (lisp ...) form — it shall not call the finalizer. + (*lisp #:<- (lisp) + (name "paren-3004") + (is-scheme? #t))) + + (match %paren-3004 + (($* lisp is-scheme? is-syntactically-scoped?) + (list is-scheme? is-syntactically-scoped?)))) + (test-env 'lisp))))) + +(test-group "match behavior" + (tu:test-assert + (or (eval '(begin + (define-module (de-paul-records-test match) + #:use-module ((de-paul-records))) + + (define (some-record? _) + #f)) + (make-env)) + #t)) + + (tu:test-error (lambda (condition) + (let ((subcond (extract-condition + condition + &exception-with-kind-and-args))) + (eq? 'match-error (condition-ref subcond 'kind)))) + (eval '(match (list 'a 'b) + (($* some-record) + "should not match")) + (test-env 'match))) + + (tu:test-error (lambda (condition) + (let ((subcond (extract-condition + condition + &exception-with-kind-and-args))) + (eq? 'unbound-variable (condition-ref subcond 'kind)))) + (eval '(match (list 'a 'b) + (($* nonexistent-record) + "should error out")) + (test-env 'match))) + + (tu:test-equal 'sth2 + (eval '(match `(($* sth1 sth2) . b) + (`(($* sth1 ,second-sth) . b) + second-sth)) + (test-env 'match))) + + (tu:test-equal "matched with predicate" + (eval '(match "matched with predicate" + ((? (lambda (_) + ;; $* form shall not get altered by match + ;; because it's inside a predicate form of + ;; (? pred pat ooo) + (define ($* a b) + b) + + ($* 'dummy #t)) + matched-value) + matched-value)) + (test-env 'match))) + + (tu:test-equal "matched with 'getter'" + (eval '(match "'getter'" + ((= (lambda (string) + ;; $* form shall not get altered by match + ;; because it's inside a field form of + ;; (= field pat) + (define ($* a b) + b) + + ($* 'dummy (string-append "matched with " + string))) + produced-value) + produced-value)) + (test-env 'match)))) + +(test-group "non-exported record <rsa-secret-key>" + (tu:test-assert + (or (eval '(begin + (define-module (de-paul-records-test rsa-secret-key-1) + #:use-module ((de-paul-records))) + + (define-immutable-record-type* rsa-secret-key + (bytes) + #:export? #f)) + (make-env)) + #t)) + + (tu:test-eq 'absent (module-ref (resolve-interface + '(de-paul-records-test rsa-secret-key-1)) + 'rsa-secret-key + 'absent)) + + (tu:test-assert + (or (eval '(begin + (define-module (de-paul-records-test rsa-secret-key-2) + #:use-module ((de-paul-records))) + + (define-immutable-record-type* rsa-secret-key + (bytes))) + (make-env)) + #t)) + + (tu:test-eq 'absent (module-ref (resolve-interface + '(de-paul-records-test rsa-secret-key-2)) + 'rsa-secret-key-bytes + 'absent))) |