Initial commit.

1 files changed, 229 insertions, 0 deletions

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)))