#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 |
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

(import (mcgoron cond-thunk values) (scheme write))

(test-begin "(mcgoron cond-thunk values)")
(test-assert
 "like cond-thunk 1"
 (cond-values
   (when-ct #t #t)
   (else #f)))

(test-assert
 "like cond-thunk 2"
 (cond-values
   (when-ct #f #f)
   (else #t)))

(define-syntax case-receive
  (syntax-rules ()
    ((case-receive generator clauses ...)
     (call-with-values (lambda () generator)
       (case-lambda clauses ...)))))

(test-assert
 "delivering no values 1"
 (case-receive (cond-values (when-ct #f #f))
   (() #t)
   (_ #f)))
(test-assert
 "delivering no values 2"
 (case-receive (cond-values (when-ct #t #t))
   (() #f)
   ((x) #t)
   (_ #f)))

(test-assert
 "after 1"
 (case-receive (cond-values
                 (after ((when #t))
                   #t))
   (() #f)
   ((x) #t)
   (_ #f)))

(test-assert
 "after 2"
 (case-receive (cond-values
                 (after ((when #f))
                   #f))
   (() #t)
   (_ #f)))

(test
 "pair=>"
 '(2 3 4)
 (cond-values
   (after ((let (pair=> #f) => (head tail)))
     'boolean)
   (after ((let (pair=> 5) => (head tail)))
     'number)
   (after ((let (pair=> "xy") => (head tail)))
     'string)
   (after ((let (pair=> '(1 2 3 4)) => (head tail)))
     tail)
   (else #f)))

(test-assert
 "length-at-least=> 1"
 (cond-values
   (after ((let (length-at-least=> '(1 2 3 4) 5)
             => _))
     #f)
   (after ((let (length-at-least=> '(1 2 3 4) 4)
             => returned))
     #t)
   (else #f)))

(cond-values
  (after ((let (length-at-least=> '(1 2 3 4) 4)
            => (a b c d rest)))
    (test "length-at-least=> 2.1" 1 a)
    (test "length-at-least=> 2.2" 2 b)
    (test "length-at-least=> 2.3" 3 c)
    (test "length-at-least=> 2.4" 4 d)
    (test-assert "length-at-least=> 2.5" (null? rest)))
  (else (error "length-at-least=> 2" #f)))

(cond-values
  (after ((let (length-at-least=> '(1 2 3 4) 3)
            => (a b c rest)))
    (test "length-at-least=> 3.1" 1 a)
    (test "length-at-least=> 3.2" 2 b)
    (test "length-at-least=> 3.3" 3 c)
    (test-assert "length-at-least=> 3.4" (equal? rest '(4))))
  (else (error "length-at-least=> 3" #f)))

(test "on-fail 1"
      5
      (cond-thunk
        (after ((when #t)
                (on-fail! 5)
                (when #f))
          'no-fail)
        (else 'else)))

(test "on-fail 2"
      'caught
      (guard (x ((eq? x 'throw) 'caught) (else 'something-else))
        (cond-thunk
          (after ((when #t)
                  (on-fail! (raise 'throw))
                  (when #f))
            'no-failed)
          (else 'else))))

(test "on-fail 3"
      'no-fail
      (cond-thunk
        (after ((on-fail! 'fail1)
                (when #t)
                (on-fail! 'fail2))
          'no-fail)
        (else 'else)))

(define-syntax with-catch-predicate
  (syntax-rules ()
    ((with-catch-predicate predicate? body ...)
     (guard (x ((predicate? x) #t)
               (else #f))
       body ...))))

(define-record-type/destructor <test-object>
  (test-object x y z)
  test-object?
  test-object=>
  (x get-x)
  (y get-y)
  (z get-z))

(let ((obj (test-object 1 2 3)))
  (test-assert
   "define-record-type/destructor"
   (cond-thunk
     (after ((let (test-object=> obj) => (a b c))
             (when (= a 1))
             (when (= b 2))
             (when (= c 3)))
       #t))))


(test-end "(mcgoron cond-thunk values)")