;;;; dsssl-utils-test.scm -*- Hen -*-

(eval-when (load)
  (print) (print "expect compiler warnings for atom-mutate!-2") (print) )

(use test)

;;

(use dsssl-utils)

(test-begin "dssl-utils")

;;

(test-group "dsssl-fixup"

  (define (f a1 a2 #!optional (o1 'x) o2 #!rest rest #!key k1 k2)
    #; ;NOTE the variables are NEW in the dsssl-fixup body so before shot
    (print `(
      (a1 ,a1 a2 ,a2)
      (o1 ,o1 o2 ,o2)
      (#:k1 ,k1 #:k2 ,k2)
      (rest ,rest)))
    (dsssl-fixup ((o1 'x) o2) ((#:k1 k1) (#:k2 k2)) rest `(
      (a1 ,a1 a2 ,a2)
      (o1 ,o1 o2 ,o2)
      (#:k1 ,k1 #:k2 ,k2)
      (rest ,rest)) ) )

  (test '((a1 1 a2 2) (o1 3 o2 #f) (#:k1 4 #:k2 #f) (rest ())) (f 1 2 #:k1 4 3))

  (test-error (f 1 2 3 #:k1 4 5 #:k2))

  (test '((a1 1 a2 2) (o1 4 o2 5) (#:k1 3 #:k2 6) (rest (7 8))) (f 1 2 #:k1 3 4 5 #:k2 6 7 8))

  (test '((a1 1 a2 2) (o1 3 o2 6) (#:k1 4 #:k2 5) (rest (7 8))) (f 1 2 3 #:k1 4 #:k2 5 6 7 8))

  (test '((a1 1 a2 2) (o1 3 o2 5) (#:k1 4 #:k2 6) (rest (7 8))) (f 1 2 3 #:k1 4 5 #:k2 6 7 8))

  (test '((a1 1 a2 2) (o1 3 o2 5) (#:k1 4 #:k2 6) (rest ())) (f 1 2 3 #:k1 4 5 #:k2 6))
)

;;

(use lambda+)

(test-group "lambda+"

  (define (foo r1 r2 #!optional o1 (o2 '()) #!rest rest #!key k1 (k2 'foo))
    `((,r1 ,r2) (,o1 ,o2) (,k1 ,k2) ,rest))

  (define+ (foo+ r1 r2 #!optional o1 (o2 '()) #!rest rest #!key k1 (k2 'foo))
    `((,r1 ,r2) (,o1 ,o2) (,k1 ,k2) ,rest))

  (test '((1 2) (3 #:k1) (#f foo) (4 5 6 7 8)) (foo 1 2 3 #:k1 4 5 6 7 8))

  (test '((1 2) (3 5) (4 foo) (6 7 8)) (foo+ 1 2 3 #:k1 4 5 6 7 8))
)

;;

(use typed-define)

(test-group "typed-define-record"

  (define:-record-type <trec>
    (make-trec a b c)
    trec?
    (a string trec-a)
    (b (or boolean number) trec-b trec-b-set!)
    (c immediate trec-c trec-c-set!) )

  (let ((trec (make-trec "a" #f #!eof)))
    (test-assert (trec? trec))
    (test #f (trec-b trec))
    (trec-b-set! trec 34)
    (test 34 (trec-b trec)) )
)

(test-group "typed-define"

  (define:-record-type <trec>
    (make-trec a b c)
    trec?
    (a string trec-a)
    (b (or boolean number) trec-b trec-b-set!)
    (c immediate trec-c trec-c-set!) )

  (define: (atom-mutate!-2 (atm <trec>) (prc procedure) . (args (list-of *))) -> *
    #f )

  (define: (atom-mutate!-1 (atm <trec>) . (args (list-of *))) -> *
    #f )

  (define: (atom-mutate!-0 . (args (list-of *))) -> *
    #f )

  (test "only needs to expand" #f (atom-mutate!-2 (void) (void) 1 2 3))
  (test "only needs to expand" #f (atom-mutate!-1 (make-trec 4 5 6) 1 2 3))
  (test "only needs to expand" #f (atom-mutate!-0 1 2 3))
)

;;

(test-end "dssl-utils")

;;

(test-exit)