Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
99 lines (83 sloc) 3.16 KB
(use strings capture equal-wrt-testing runtime re)
(def skip-newlines ((o in stdin))
(when (re-match "^ *\r?\n" in)
(skip-newlines in)))
(def parse-test-expr-block (indentation)
(let expr (readline)
(= expr (+ expr "\n"))
((afn ()
(when (re-looking-at "^ ")
(= expr (+ expr (cut (readline) indentation) "\n"))
(self))))
expr))
(def parse-expression (indentation)
`((expr ,(parse-test-expr-block indentation))))
(def read-upto-empty-line ()
(string:accum a
((afn ()
(let line (readline)
(when (and line (> len.line 0))
(a (+ line "\n"))
(self)))))))
(def parse-backslash-escapes (s)
(multisubst '(("\\\\" "\\") ("\\n" "\n")) s))
(def parse-test-result ()
(accum a
(let lines (read-upto-empty-line)
(w/stdin (instring lines)
((afn ()
(when (peekc)
(aif (re-match "^prints: ")
(a `(prints ,(parse-backslash-escapes:readline)))
(re-match "^err: ")
(a `(err ,(parse-backslash-escapes:readline)))
(re-match "^stderr: ")
(a `(errout ,(parse-backslash-escapes:readline)))
(a `(val ,(parse-test-expr-block 0))))
(self))))))))
(def parse-one-test-spec ()
(skip-newlines)
(if (peekc)
(let spaces (re-match "^>( +)")
(unless spaces (err "expecting >"))
(+ (parse-expression len.spaces)
(parse-test-result)))))
(def parse-test-specs ()
(drain (parse-one-test-spec)))
(def write-val (runtime result)
(aif (assoc 'val result)
(+ `((val ,(tostring (runtime!write cadr.it))))
(rem [is (car _) 'val] result))
result))
(def eval-test (runtime spec)
(write-val runtime
(capture-val-out-errout
(fn ()
(runtime!eval (runtime!read (alref spec 'expr)))))))
(def check-test-result (runtime expected actual)
(catch
(if (and (alref actual 'err) (no (alref expected 'err)))
(throw (+ "error: " (alref actual 'err)))
(each (key expected-value) (keep [in (car _) 'val 'err 'prints 'stderr] expected)
(let actual-value-assoc (assoc key actual)
(if (no actual-value-assoc)
(throw (+ "expected " key " " (tostring:write expected-value) ", "
"not present in actual result: "
(tostring:write actual)))
(let actual-value (cadr actual-value-assoc)
(if (isnt (trim expected-value 'end)
(trim actual-value 'end))
(throw (+ "expected " key " " (tostring:write expected-value) ", "
"actual " (tostring:write actual)))))))))))
(def example-test (runtime spec-string)
(let specs (fromstring spec-string (parse-test-specs))
(each spec specs
(let actual (eval-test runtime spec)
(aif (check-test-result runtime spec actual)
(do (pr "FAIL ")
(write spec)
(prn " " it)
(err "test failed"))
(do (pr "ok ")
(write spec)
(prn)))))))
Jump to Line
Something went wrong with that request. Please try again.