Make alist procedures generation switchable with a keyword.

2 files changed, 100 insertions, 34 deletions

diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm
index f626667..16ac7d9 100644
--- a/src/guile/de-paul-records.scm
+++ b/src/guile/de-paul-records.scm
@@ -71,10 +71,21 @@
                   #'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))
+    (name        record-spec-name         record-spec-set-name)
+    (fields      record-spec-fields       record-spec-set-fields)
+    (alist-ctor? record-spec-alist-ctor?  record-spec-set-alist-ctor?)
+    (alist-szer? record-spec-alist-szer?  record-spec-set-alist-szer?)
+    (export?     record-spec-export?      record-spec-set-export?)
+    (finalize    record-spec-finalize     record-spec-set-finalize))
+
+  (define record-spec-alist-constructor?
+    record-spec-alist-ctor?)
+  (define record-spec-set-alist-constructor?
+    record-spec-set-alist-ctor?)
+  (define record-spec-alist-serializer?
+    record-spec-alist-szer?)
+  (define record-spec-set-alist-serializer?
+    record-spec-set-alist-szer?)
 
   (define record-spec-field-proc
     (compose (cute eval <> (resolve-module '(de-paul-records)))
@@ -89,7 +100,7 @@
     (cut record-spec-field-proc <> "record-spec-set-~a"))
 
   (define %bool-flag-field-keywords
-    '(#:export?))
+    '(#:alist-constructor? #:alist-serializer? #:export?))
 
   (define %null-record-spec
     (fold (lambda (keyword record)
@@ -109,6 +120,11 @@
               ((record-spec-name) #'record-name)
               ((record-spec-fields) (reverse (record-spec-fields
                                               record-spec)))))
+           ((#:alist-procs? value . args-rest)
+            (loop record-spec
+                  #`(#,(datum->syntax #'value #:alist-constructor?) value
+                     #,(datum->syntax #'value #:alist-serializer?) value
+                     . args-rest)))
            ((bool-flag-keyword value . args-rest)
             (let ((keyword (syntax->datum #'bool-flag-keyword)))
               (and (memq keyword %bool-flag-field-keywords)
@@ -213,10 +229,12 @@
   (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)))
+                                   (= record-spec-name        record-name)
+                                   (= record-spec-fields      field-specs)
+                                   (= record-spec-alist-ctor? alist-ctor?)
+                                   (= record-spec-alist-szer? alist-szer?)
+                                   (= record-spec-export?     export?)
+                                   (= record-spec-finalize    finalize)))
        (with-syntax ((<record> (format-identifiers "<~a>" record-name))
                      (--make-record (format-identifiers "--make-~a"
                                       record-name))
@@ -260,34 +278,47 @@
              (define-syntax-rule (#,record-name . body-rest)
                (--finalize-record (*record . body-rest)))
 
-             (define (*alist->record alist)
-               (*record
-                #,@(map (match-lambda
-                          ((= field-spec-name field-name)
-                           #`(#,field-name
-                              (or (and=> (assq '#,field-name alist)
-                                         cdr)
-                                  (#,(format-identifiers "~a-~a"
-                                       record-name field-name)
-                                   %null-record)))))
-                        field-specs)))
-
-             (define (alist->record alist)
-               (--finalize-record (*alist->record alist)))
-
-             (define (record->alist record)
-               `(#,@(map (match-lambda
-                           ((= field-spec-name field-name)
-                            #`(#,field-name
-                               . ,(#,(format-identifiers "~a-~a"
-                                       record-name field-name)
-                                   record))))
-                         field-specs)))
+             #,@(if (eq? alist-ctor? #t)
+
+                    #`((define (*alist->record alist)
+                         (*record
+                          #,@(map (match-lambda
+                                    ((= field-spec-name field-name)
+                                     #`(#,field-name
+                                        (or (and=> (assq '#,field-name alist)
+                                                   cdr)
+                                            (#,(format-identifiers "~a-~a"
+                                                 record-name field-name)
+                                             %null-record)))))
+                                  field-specs)))
+
+                       (define (alist->record alist)
+                         (--finalize-record (*alist->record alist))))
+
+                    '())
+
+             #,@(if (eq? alist-szer? #t)
+
+                    #`((define (record->alist record)
+                         `(#,@(map (match-lambda
+                                     ((= field-spec-name field-name)
+                                      #`(#,field-name
+                                         . ,(#,(format-identifiers "~a-~a"
+                                                 record-name field-name)
+                                             record))))
+                                   field-specs))))
+
+                    '())
 
              #,@(if (eq? export? #t)
                     (list
                      #`(export <record> #,record-name record? %null-record
-                               *alist->record alist->record record->alist
+                               #,@(if (eq? alist-ctor? #t)
+                                      #'(*alist->record alist->record)
+                                      '())
+                               #,@(if (eq? alist-szer? #t)
+                                      #'(record->alist)
+                                      '())
                                #,@(append-map
                                    (match-lambda
                                      ((= field-spec-name field-name)
diff --git a/tests/guile/de-paul-records-test.scm b/tests/guile/de-paul-records-test.scm
index 630009c..a1bef01 100644
--- a/tests/guile/de-paul-records-test.scm
+++ b/tests/guile/de-paul-records-test.scm
@@ -2,7 +2,9 @@
 ;;;
 ;;; Copyright (C) 2023, 2025 Wojtek Kosior <koszko@koszko.org>
 
-(use-modules ((srfi srfi-35) #:select (extract-condition condition-ref))
+(use-modules ((srfi srfi-26) #:select (cut cute))
+             ((srfi srfi-35) #:select (extract-condition condition-ref))
+             ((ice-9 match) #:select (match-lambda))
              ((ice-9 safe-r5rs) #:select (null-environment))
              ((srfi srfi-64) #:select (test-group))
              ((myra-test-utils) #:prefix tu:))
@@ -25,6 +27,7 @@
                 (deftype lisp
                   (name)
                   is-scheme?
+                  #:alist-procs? sure,whynot?
                   #:export? yes,ofcourse
                   (is-syntactically-scoped? #:default #f)
                   #:finalize (lambda (the-lisp)
@@ -258,3 +261,35 @@
                                    '(de-paul-records-test rsa-secret-key-2))
                                   'rsa-secret-key-bytes
                                   'absent)))
+
+(test-group "exported record <rsa-public-key>"
+  (tu:test-assert
+   (for-each (match-lambda
+               ((id constructor?)
+                (or (eval `(begin
+                             (define-module (de-paul-records-test ,id)
+                               ;; This time export the record.
+                               #:use-module (de-paul-records))
+
+                             (deftype rsa-public-key
+                               (bytes)
+                               #:export? #t
+                               #:alist-constructor? ,constructor?))
+                          (make-env))
+                    #t)))
+             '((rsa-public-key-1 #f) (rsa-public-key-2 #t))))
+
+  (tu:test-equal '((absent absent absent)
+                   (absent present present))
+                 (map (lambda (id)
+                        (map (compose (cut or <> 'absent)
+                                      (cut and <> 'present)
+                                      procedure?
+                                      (cute module-ref
+                                            (resolve-interface
+                                             `(de-paul-records-test ,id))
+                                            <> #f))
+                             '(rsa-public-key->alist
+                               *alist->rsa-public-key
+                               alist->rsa-public-key)))
+                      '(rsa-public-key-1 rsa-public-key-2))))