expand2

test/old_test.clj

@@ -0,0 +1,152 @@
+(ns old-test
+  (:require
+   [clojure.core.match :refer [match]]
+   [clojure.spec.alpha :as s]
+   [clojure.test :as t]
+   [old :as sut]))
+
+(t/deftest scheme-base-test
+  (t/is (s/valid? ::sut/environment (:env sut/scheme-base)))
+  (t/is (s/valid? ::sut/symtable (:symtable sut/scheme-base))))
+
+(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` does not clobber caller's scope")
+      (t/is (= '(let (([x #{s0}] 123))
+                  (let-syntax ((m (syntax-rules () ((m) x))))
+                    (lambda ([x #{s1 s2 s0}])
+                            [x #{s0 s3}])))
+               (sut/rg-expand '(let ((x 123))
+                                 (let-syntax ((m (syntax-rules
+                                                  ()
+                                                  ((m) x))))
+                                   (λ (x)
+                                      (m))))))
+            "`when` does not capture caller's scope")
+      (t/is (= '(if 123 (begin (display "hello")
+                               (newline)))
+               (sut/us-expand '(when 123
+                                 (display "hello")
+                                 (newline))))
+            "`when` captures multiple"))))
+
+(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))))