diff options
Diffstat (limited to 'tests/guile/de-paul-records-test.scm')
| -rw-r--r-- | tests/guile/de-paul-records-test.scm | 229 |
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))) |