Carp/core/Test.carp

(defmodule IO
  (hidden color-table)
  (def color-table
    [[@"black" @"30"]
     [@"red" @"31"]
     [@"green" @"32"]
     [@"yellow" @"33"]
     [@"blue" @"34"]
     [@"magenta" @"35"]
     [@"cyan" @"36"]
     [@"white" @"37"]
     [@"reset" @"0"]
     [@"none" @"0"]
     [@"bold" @"1"]
     [@"italic" @"3"]
     [@"underline" @"4"]
     [@"blink-slow" @"5"]
     [@"blink-rapid" @"6"]
     [@"bg-black" @"40"]
     [@"bg-red" @"41"]
     [@"bg-green" @"42"]
     [@"bg-yellow" @"43"]
     [@"bg-blue" @"44"]
     [@"bg-magenta" @"45"]
     [@"bg-cyan" @"46"]
     [@"bg-white" @"47"]])

  (hidden len-color-table)
  (def len-color-table (Array.length &color-table))

  (hidden color-name-to-ansi)
  (defn color-name-to-ansi [cname]
    (let [res @""]
      (do
        (for [i 0 len-color-table]
          (if (String.= cname (Array.nth (Array.nth &color-table i) 0))
             (set! res @(Array.nth (Array.nth &color-table i) 1))
             ()))
        (StringCopy.append @"\x1b[" (StringCopy.append res @"m")))))

  (hidden color)
  (defn color [cname]
    (print &(color-name-to-ansi cname)))
  )

(defmodule Test
  (deftype State [passed Int, failed Int])

  (hidden handler)
  (defn handler [state expected actual descr what op]
    (if (op expected actual)
      (do
        (IO.color "green")
        (IO.println &(string-join @"Test '" @descr @"' passed"))
        (IO.color "reset")
        (State.update-passed (State.copy state) Int.inc))
      (do
        (IO.color "red")
        (IO.println &(string-join @"Test '" @descr @"' failed:"))
        (IO.print &(string-join @"\tExpected " @what @": '"))
        (IO.print &(str expected))
        (IO.println &(string-join @"', actual value: '" (str actual) @"'"))
        (IO.color "reset")
        (State.update-failed (State.copy state) Int.inc))))

  (doc assert-op "Assert that op returns true when given x and y.")
  (defn assert-op [state x y descr op]
    (handler state x y descr "value" op))

  (doc assert-equal "Assert that x and y are equal. Equality needs to be implemented for their type.")
  (defn assert-equal [state x y descr]
    (handler state x y descr "value" =))

  (doc assert-not-equal "Assert that x and y are not equal. Equality needs to be implemented for their type.")
  (defn assert-not-equal [state x y descr]
    (handler state x y descr "not value" /=))

  (doc assert-true "Assert that x is true.")
  (defn assert-true [state x descr]
    (assert-equal state true x descr))

  (doc assert-false "Assert that x is false.")
  (defn assert-false [state x descr]
    (assert-equal state false x descr))

  (doc reset "Reset test state.")
  (defn reset [state]
    (State.set-failed (State.set-passed state 0) 0))

  (hidden run-child)
  (defn run-child [x]
    (let [pid (System.fork)
          status 0]
      (if (= pid 0)
        (do
          (x)
          0)
        (do
          (ignore (System.wait (address status)))
          (System.get-exit-status status)))))

  (hidden handle-signal)
  (defn handle-signal [x] (System.exit x))

  (hidden run-child-signals)
  (defn run-child-signals [x]
    (let [pid (System.fork)
          status 0]
      (if (= pid 0)
        (do
          (System.signal System.signal-abort handle-signal)
          (System.signal System.signal-fpe handle-signal)
          (System.signal System.signal-ill handle-signal)
          (System.signal System.signal-segv handle-signal)
          (System.signal System.signal-term handle-signal)
          (x)
          0)
        (do
          (ignore (System.wait (address status)))
          (System.get-exit-status status)))))

  (doc assert-exit "Assert that function f exits with exit code exit-code.")
  (defn assert-exit [state exit-code f descr]
    (assert-equal state exit-code (run-child f) descr))

  (doc assert-exit "Assert that function f aborts with OS signal signal.")
  (defn assert-signal [state signal x descr]
    (assert-equal state signal (run-child-signals x) descr))

  (doc print-test-results "Print test results.")
  (defn print-test-results [state]
    (let [passed @(State.passed state)
          failed @(State.failed state)]
      (do
        (IO.println "Results:")
        (if (Int.> (Int.+ passed failed) 0)
          (do
            (IO.color "green")
            (if (Int.> passed 0) (IO.print &(StringCopy.append @"\t|" (String.repeat passed "="))) ())
            (if (Int.= failed 0) (IO.print "|") ())
            (IO.color "red")
            (if (Int.= passed 0) (IO.print "\t|") ())
            (if (Int.> failed 0) (IO.print &(StringCopy.append (String.repeat failed "=") @"|")) ())
            (IO.println ""))
          ())
        (IO.color "green")
        (IO.print "\tPassed: ")
        (IO.print &(Int.str passed))
        (IO.color "red")
        (IO.print "\tFailed: ")
        (IO.println &(Int.str failed))
        (IO.color "reset")
        (State.copy state))))
)

(defdynamic with-test-internal [name forms]
  (if (= (length forms) 1)
    (list (list 'set! name (list 'ref (car forms))))
    (cons (list 'set! name (list 'ref (car forms)))
          (with-test-internal name (cdr forms)))))


(defmacro with-test [name :rest forms]
  (list 'let [name '&(Test.State.init 0 0)]
    (cons-last
      (list 'Int.copy (list 'Test.State.failed name))
      (cons 'do (with-test-internal name forms)))))

(defmacro deftest [name state-name :rest forms]
  (list 'defn name []
    (list 'let [state-name '&(Test.State.init 0 0)]
      (cons-last
        (list Test.print-test-results state-name)
        (cons 'do (with-test-internal state-name forms))))))