#| Copyright (C) 2025 Peter McGoron
 |
 | Permission is hereby granted, free of charge, to any person obtaining a
 | copy of this software and associated documentation files (the
 | "Software"), to deal in the Software without restriction, including
 | without limitation the rights to use, copy, modify, merge, publish,
 | distribute, sublicense, and/or sell copies of the Software, and to
 | permit persons to whom the Software is furnished to do so, subject to
 | the following conditions:
 |
 | The above copyright notice and this permission notice (including the
 | next paragraph) shall be included in all copies or substantial portions
 | of the Software.
 |
 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.

 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 |#

(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions))

(test-begin "SRFI 259")

(define-procedure-tag tag-foo tag-foo? get-tag-foo)
(define-procedure-tag tag-baz tag-baz? get-tag-baz)

(test-group "tagging lambdas"
  (let* ((var 100)
         (tagged (tag-foo 'bar (lambda (x)
                                 (set! var (+ var x))
                                 var))))
    (test-assert "tag-foo is tag-foo?" (tag-foo? tagged))
    (test "get-tag-foo returns tagged value" 'bar (get-tag-foo tagged))
    (test "var is previous value" 100 var)
    (test "tagged procedure is callable" 110 (tagged 10))
    (test "var has changed" 110 var)
    (test-assert "not tag-baz?" (not (tag-baz? tagged)))
    (test "get-tag-baz raises an exception"
          'assertion
          (condition-case (begin (get-tag-baz tagged) 'success)
                          ((exn assertion) 'assertion)
                          (exn () 'error)))
    (test-group "tagged again"
      (let ((tagged-again (tag-foo 'quux tagged)))
        (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again))
        (test "tagging again sets new value" 'quux (get-tag-foo tagged-again))
        (gc #f)
        (test "tagging again retains old value in previous procedure" 'bar (get-tag-foo tagged))
        (test-assert "the procedures not eqv?" (not (eqv? tagged tagged-again)))
        (test "tagging again returns a procedure" 150 (tagged 40))
        (test "var has changed" 150 var)))
    (test-group "tagged baz"
      (let ((tagged-baz (tag-baz 'corge tagged)))
        (test-assert "tag-baz?" (tag-baz? tagged-baz))
        (test-assert "tag-baz and tag-foo?" (tag-foo? tagged-baz))
        (test "retains get-tag-foo" 'bar (get-tag-foo tagged-baz))
        (test "retains get-tag-baz" 'corge (get-tag-baz tagged-baz))
        (test-assert "previous procedure is not tag-baz?" (not (tag-baz? tagged)))))))

(test-group "tagging imported procedures"
  (let* ((tagged (tag-foo 'foo +))
         (tagged (tag-baz 'baz tagged)))
    (test-assert "not tag-foo?" (not (tag-foo? +)))
    (test-assert "not tag-baz?" (not (tag-baz? +)))
    (test-assert "tag-foo?" (tag-foo? tagged))
    (test-assert "tag-baz?" (tag-baz? tagged))
    (test "operationally the same procedure?"
          (+ 50 50)
          (tagged 50 50))
    (test "get-tag-foo" 'foo (get-tag-foo tagged))
    (test "get-tag-baz" 'baz (get-tag-baz tagged))))

(define-syntax raises-type-error
  (syntax-rules ()
    ((raises-type-error name expr)
     (test name
           'type
           (condition-case (begin expr 'success)
                           ((exn type) 'type)
                           (var () (display (condition->list var)) 'error))))))

(test-group "predicates on other objects"
  (test-assert "integers are not tagged" (not (tag-foo? 0)))
  (raises-type-error "integers are not tagged" (tag-foo 'data 0))
  (test-assert "strings are not tagged" (not (tag-foo? "hello")))
  (raises-type-error "strings are not tagged" (tag-foo 'data "hello"))
  (test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4))))
  (raises-type-error "bytevectors are not tagged" (tag-foo 'data #u8(1 2 3 4)))
  (test-assert "vectors are not tagged" (not (tag-foo? #(call/cc))))
  (raises-type-error "vectors are not tagged" (tag-foo 'data #(call/cc)))
  (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
  (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))

(test-group "define-procedure-tag is a define form"
  (let ()
    (define (square x) (* x x))
    (define-procedure-tag tag-order tag-order? get-tag-order)
    (define tagged-square (tag-order 2 square))
    (define-procedure-tag tag-pure tag-pure? get-tag-pure)
    (define tagged-square (tag-pure #t tagged-square))
    (test-assert "square is tag-order?" (tag-order? tagged-square))
    (test-assert "square is tag-pure?" (tag-pure? tagged-square))
    (test "square order" 2 (get-tag-order tagged-square))
    (test-assert "square pure" (get-tag-pure tagged-square))
    (test-assert "is a procedure?" (procedure? tagged-square))
    (test "square value" (tagged-square 10) (square 10))))

(test-end "SRFI 259")

(test-begin "SRFI 259 extensions")

(define/this (try-this this x)
  (when (tag-foo? this)
    (set! x (+ x (get-tag-foo this))))
  (when (tag-baz? this)
    (set! x (+ x (get-tag-baz this))))
  x)

(test "no tag" 10 (try-this 10))

(define new-try-this (tag-foo 10 try-this))
(test "with tag-foo" 20 (new-try-this 10))
(test "does not affect the one with no tag" 10 (try-this 10))

(define new-new-try-this (tag-baz 20 new-try-this))
(test "with tag-baz" 40 (new-new-try-this 10))
(test "does not affect the one with tag-foo" 20 (new-try-this 10))
(test "does not affect the one with no tag" 10 (try-this 10))

(test-end "SRFI 259 extensions")
(test-exit)