;;; 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)
(authors #:default '())
#: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
authors
is-syntactically-scoped?
name
is-scheme?)
(list is-syntactically-scoped?
authors
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-3001.1"
(tu:test-equal '#t
(eval
'(begin
(define %paren-3001.1
(lisp #:<- %paren-3001
(name #:->
((const 'test-noop))
(string-append name ".1"))
(authors #:list "Jane Doe")
(is-syntactically-scoped? #t)))
(match `(a . ,%paren-3001.1)
(`(a . ,($* lisp is-syntactically-scoped?))
is-syntactically-scoped?)))
(test-env 'lisp)))
(tu:test-equal '(#f "paren-3001.1")
(eval
'(match (vector %paren-3001.1)
(#(($* lisp is-scheme? name))
(list is-scheme? name)))
(test-env 'lisp)))
(tu:test-equal '("Jane Doe")
(eval '(lisp-authors %paren-3001.1)
(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
(authors #:list "Jane Doe" "John Smith")
(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)))
(tu:test-equal '("Jane Doe" "John Smith")
(eval '(lisp-authors %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 #:=> (const "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)))
