144 lines
4.5 KiB
Clojure
144 lines
4.5 KiB
Clojure
(ns expand-test
|
|
(:require
|
|
[clojure.core.match :refer [match]]
|
|
[clojure.spec.alpha :as s]
|
|
[clojure.test :as t]
|
|
[expand :as sut]))
|
|
|
|
(t/deftest scheme-base-env-test
|
|
(t/is (s/valid? ::sut/environment sut/scheme-base-env)))
|
|
|
|
(t/deftest symtable-for-env-test
|
|
(t/is (s/valid? ::sut/symtable (sut/symtable-for-env sut/scheme-base-env))))
|
|
|
|
(t/deftest nearest-test
|
|
(t/is (= [:primitive 'lambda]
|
|
(sut/lookup ['lambda #{}]
|
|
sut/scheme-base-env
|
|
(sut/symtable-for-env sut/scheme-base-env))))
|
|
(t/is (= [#{0 1}]
|
|
(sut/nearest ['x #{0 1 2}]
|
|
[#{0} #{0 1} #{0 3}]))))
|
|
|
|
(t/deftest pattern-spec
|
|
(t/testing "var"
|
|
(let [pattern-var? #(match (s/conform ::pattern %)
|
|
[:var _] true
|
|
_ false)]
|
|
(t/is (pattern-var? 'abc))
|
|
(t/is (not (pattern-var? '_)))
|
|
(t/is (not (pattern-var? '...)))))
|
|
(t/testing "list"
|
|
(t/are [l e t x] (= [l e t]
|
|
((juxt :leading :ellipsis :trailing)
|
|
(s/conform ::pattern x)))
|
|
nil nil nil '()
|
|
'(a) nil nil '(a)
|
|
'(a b) nil nil '(a b)
|
|
'(a) 'b nil '(a b ...)
|
|
'(a) 'b '(c) '(a b ... c)
|
|
'(a) 'b '(c d) '(a b ... c d))
|
|
(t/are [p] (s/invalid? ::pattern p)
|
|
'... '(...) '(... a b c)
|
|
'(a ... b ...)))
|
|
(t/testing "simple data"
|
|
(t/is (= 'a (s/conform ::patern 'a)))))
|
|
|
|
(t/deftest expand-test
|
|
(t/testing "unbound symbol"
|
|
(t/is (thrown? Exception (sut/expand 'x))))
|
|
(t/testing "lambda"
|
|
(t/is (= '(lambda (x) x)
|
|
(sut/us-expand '(λ (x) x)))))
|
|
(t/testing "let-syntax"
|
|
(t/is (= '(let-syntax ((m (syntax-rules
|
|
()
|
|
((m) 123))))
|
|
456)
|
|
(sut/expand
|
|
'(let-syntax ((m (syntax-rules
|
|
()
|
|
((m) 123))))
|
|
456)))))
|
|
(t/testing "let"
|
|
(t/is (= '(let ((x 123)
|
|
(y 456))
|
|
(+ x y))
|
|
(sut/us-expand
|
|
'(let ((x 123)
|
|
(y 456))
|
|
(+ x y))))))
|
|
(t/testing "application"
|
|
(t/is (= '(lambda (f x) (f x))
|
|
(sut/us-expand '(lambda (f x) (f x))))))
|
|
(t/testing "macros"
|
|
(t/testing "when"
|
|
(t/is (= '(let ((x 123)) (if x 456))
|
|
(sut/us-expand '(let ((x 123))
|
|
(when x 456)))))
|
|
(t/is (= '(let (([body #{s0}] 123))
|
|
(if [body #{s0}]
|
|
456))
|
|
(sut/rg-expand '(let ((body 123))
|
|
(when body 456))))
|
|
"`when` is hygienic"))
|
|
(t/is (sut/rg-expand '(let ((x 123))
|
|
(let-syntax ((m (syntax-rules
|
|
()
|
|
((m) x))))
|
|
(λ (x)
|
|
(m))))))))
|
|
|
|
(t/deftest prim-lambda-spec
|
|
(t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))
|
|
(t/is (s/valid? ::sut/prim-lambda '(lambda (x) (display x) (newline)))))
|
|
|
|
(t/deftest prim-let-spec
|
|
(t/is (s/valid? ::sut/prim-let '(let ((x 123)
|
|
(y 456))
|
|
(+ x y)))))
|
|
|
|
(t/deftest prim-let-syntax-spec
|
|
(t/is (s/valid? ::sut/prim-let-syntax
|
|
'(let-syntax ((m (syntax-rules ()
|
|
((m) 123))))
|
|
(m)))))
|
|
|
|
(t/deftest template-spec
|
|
(t/is (s/valid? ::sut/template '(x ... y)))
|
|
(t/is (s/valid? ::sut/template 123))
|
|
(t/is (= '[:list [[:var x]
|
|
[:ellipsis [:var y]]
|
|
[:ellipsis [:var z]]
|
|
[:var a]
|
|
[:var b]
|
|
[:var c]]]
|
|
(s/conform ::sut/template '(x y ... z ... a b c)))))
|
|
|
|
(t/deftest pattern-spec
|
|
(t/is (s/valid? ::sut/pattern '(m))))
|
|
|
|
(t/deftest rule-spec
|
|
(t/is (s/valid? ::sut/rule '((m) 123))))
|
|
|
|
(t/deftest prim-syntax-rules-spec
|
|
(t/is (s/valid? ::sut/prim-syntax-rules
|
|
'(syntax-rules
|
|
()
|
|
((m) 123)))))
|
|
|
|
(t/deftest unify-test
|
|
(t/are [result pattern datum] (= result (sut/unify pattern datum))
|
|
{'a 123 'b 456} '(a b) '(123 456)
|
|
nil '(a b) 123
|
|
|
|
'{b [:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)])]}
|
|
'((b ...) ...)
|
|
'((1 2) (3 4))
|
|
|
|
{} '_ 123)
|
|
(t/testing "non-matches"
|
|
(t/are [pattern datum] (= nil (sut/unify pattern datum))
|
|
'(a b c) '(1 2)
|
|
'(a b c) '(1 2))))
|