;;; 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-3001.1"
    (tu:test-equal '#t
                   (eval
                    '(begin
                       (define %paren-3001.1
                         (lisp #:<- %paren-3001
                               (name #:->
                                     ((const 'test-noop))
                                     (string-append name ".1"))
                               (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))))

  (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 #:=> (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)))