Initial commit.

2 files changed, 371 insertions, 0 deletions

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: