(import test)

(import (only (chicken format) format) (test-utils gloss))

;;

(test-begin "More Macros")

(import moremacros)

;;

(cond-expand
  (compiling
    (test-group "Expansion Time Info"
      (let ((lno (__line__)))
        (glossf "(__date__): ~S" (__date__))
        (glossf "(__time__): ~S" (__time__))
        (glossf "(__file__): ~S" (__file__))
        (glossf "(__line__): ~S" lno)
        (test "(__file__)" "moremacros-test.scm" (__file__))
        (test "(__line__)" 16 lno) ) ) )
  (else) )

;;

(test-group "Either/Or"
  (test-assert (true #f))
  (test-assert (not (false #t)))
  (test-assert (true? #t))
  (test-assert (not (true? 1)))
  (test-assert (false? #f))
)

#;
(test-group "lets"
  (test 2 (lets (a 1 b a c (add1 a)) (add1 b) (void) c))
  (test-assert (lets () #t))
)

(test-group "case-like operators"
  (test "select-with" #t
    (select-with string=? "bars"
      (("foo" (string-append "foo" "s"))
        'foo)
      (("bar" (string-append "bar" "s"))
        #t)
      (else
        #f)))
  (test "case-with" #t
    (case-with eq? 'bars
      ((foo foos)
        'foo)
      ((bar bars)
        #t)
      (else
        #f)))
  (test "switch" #t
    (switch '(foo)
      (("foo" 'foo)
        'foo)
      (('(foo) 'foo)
        #t)
      (else
        #f)))
)

(test-group "swap!"
  (let ((a 1) (b 2))
    (test "swap! before" '(1 2) (list a b))
    (swap! a b)
    (test "swap! after" '(2 1) (list a b)) )
)

#;
(test-group "swap-set!, fluid-set!, stiff-set!"
  (let ((a 1) (b 2))
    (test "swap-set! before" '(1 2) (list a b))
    (swap-set! a b)
    (test "swap-set! after" '(2 1) (list a b)) )
  (let ((a 1) (b 2))
    (test "fluid-set! before" '(1 2) (list a b))
    (fluid-set! a 23 b (+ a b) (begin
      (test "fluid-set! during" '(23 25) (list a b))))
    (test "fluid-set! after" '(1 2) (list a b)) )
  (let ((a 1) (b 2))
    (test "stiff-set! before" '(1 2) (list a b))
    (stiff-set! a 23 b (+ a b))
    (test "stiff-set! after" '(23 25) (list a b)) )
)

(test-group "set!-op"
  (let ((a 1) (b 2))
    (set!-op a + 2 <> b)
    (test 5 a) )
)

(test-group "type-case"
  (test 'numeric
    (type-case 23
      ((symbol string char) 'symbolic)
      (number               'numeric)
      (else                 'otheric)))
  (test '(23 numeric)
    (type-case* 23
      ((symbol string char) (list it 'symbolic))
      (number               (list it 'numeric))
      (else                 (list it 'otheric))))
)


(test-group "guards"
  (define (tstprm1) 'foo)

  (define tstgrd1 (warning-guard tstprm1 symbol
    ;ugh, automagic identifier injection
    (format #t "testing body: ~S " obj)))

  (define (check-symbol l x) (unless (symbol? x) (error l "not a symbol" x)) x)

  (define tstgrd2 (checked-guard tstprm1 symbol
    ;ugh, automagic identifier injection
    (format #t "testing body: ~S " obj)))

  (test 'bar (tstgrd1 'bar))
  (test "expect warning" 'foo (tstgrd1 #f))

  (test 'bar (tstgrd2 'bar))
  (test-error "raises error" (tstgrd2 #f))
)

;;

(import numeric-macros)

(test-group "Numeric Macros"
  (let ((ia 1) (fa 1.0))
    (test 2 (fx++ ia))
    (test 0 (fx-- ia))
    (test 2.0 (fp++ fa))
    (test 0.0 (fp-- fa))
    (test 2.0 (fl++ fa))
    (test 0.0 (fl-- fa))
    (test 2 (1+ ia))
    (test 2 (++ ia))
    (test 2.0 (++ fa))
    (test 0 (1- ia))
    (test 0 (-- ia))
    (test 0.0 (-- fa)) )
  (let ((ia 1))
    (fx++! ia)
    (test 2 ia)
    (fx--! ia)
    (test 1 ia) )
  (let ((fa 1.0))
    (fp++! fa)
    (test 2.0 fa)
    (fp--! fa)
    (test 1.0 fa)
    (fl++! fa)
    (test 2.0 fa)
    (fl--! fa)
    (test 1.0 fa) )
  (let ((ia 1) (fa 1.0))
    (++! ia)
    (test 2 ia)
    (++! fa)
    (test 2.0 fa)
    (--! ia)
    (test 1 ia)
    (--! fa)
    (test 1.0 fa) )
  (test-assert (seven? 7))
  (test-assert (not (seven? 5)))
)

;;

(import hash-let srfi-69)

(test-group "Hash Let"
  (let ((tbl (make-hash-table)))
    ;set!
    (hash-table-set! tbl 'abc "commercial network")
    (hash-table-set! tbl "nbc" "commercial network")
    ;ref
    (hash-let tbl
      ((abc)                              ;key symbol 'abc
       (cbs "nbc")                        ;supplied string key
       (pbs (string-append "p" "bs") #t)  ;default value for missing "pbs"
       tbs)                               ;missing key symbol 'tbs
      (test "commercial network" abc)
      (test "commercial network" cbs)
      (test #t pbs)
      (test #f tbs) ) )
)

;;

(test-end  "More Macros")

(test-exit)