diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj index 177f693..cd778c8 100644 --- a/src/expand/syntax_rules.clj +++ b/src/expand/syntax_rules.clj @@ -68,6 +68,18 @@ (or (= '... x) (and (scm/syntax? x) (-> x scm/syntax-e ellipsis?)))) +(defn pattern-vars [pattern] + ;; 안 예쁘는데ㅠㅠ + (let [vs (atom #{})] + (walk/prewalk (fn [x] + (when (and (scm/identifier? x) + (not (wildcard? x)) + (not (ellipsis? x))) + (swap! vs #(conj % x))) + x) + pattern) + @vs)) + (defn unify [pattern datum] (match [(scm/syntax-e pattern) (scm/syntax-e datum)] [(_ :guard wildcard?) _] {} @@ -79,13 +91,22 @@ [([p (_ :guard ellipsis?) & ps] :seq) (ds :guard seq?)] - (let [ds-end (take-last (count ps) ds) - ds-start (drop-last (count ps) ds)] + (let [ds-end (or (take-last (count ps) ds) + (list)) + ds-start (or (drop-last (count ps) ds) + (list))] (merge-unify (some->> ds (map #(some-> (unify p %) (update-vals list))) - (apply merge-unify-with concat) + (apply merge-unify-with concat + ;; 여기에 이 map이 없으면 ds 빌 때 `unify`는 + ;; {}을 생성할 잘못되게 것이다. 그때 + ;; variable들은 bound을 안 될 것이다. 대신에 + ;; empty ellipsis로 bind해야 한다. + (into {} + (for [v (pattern-vars p)] + [(scm/syntax-e v) (list)]))) (map (fn [[k v]] [k [:ellipsis v]])) (into {})))) diff --git a/test/expand/syntax_rules_test.clj b/test/expand/syntax_rules_test.clj index f9a3fde..dd67fee 100644 --- a/test/expand/syntax_rules_test.clj +++ b/test/expand/syntax_rules_test.clj @@ -4,12 +4,50 @@ [clojure.test :as t] [clojure.walk :as walk])) +(defmacro broken-is [form] + `(t/is (not ~form) + "(expected failure, broken)")) + +(defn- pattern-vars [p] + (->> p + scm/datum->syntax-recursive + sut/pattern-vars + (map #(if (scm/syntax? %) + (scm/syntax-e %) + %)) + (into #{}))) + +(t/deftest pattern-vars-test + (t/testing "no variables" + (t/are [x] (= #{} (pattern-vars x)) + '() + '(_ ...) + 123 + true + '(123 456) + '(() ()) + '(_ (_ _) ... _))) + (t/is (= '#{a b c} + (pattern-vars '(a b c)))) + (t/is (= '#{a c} + (pattern-vars '(a _ c)))) + (t/is (= '#{a c} + (pattern-vars '(a ... _ c)))) + (t/is (= '#{a b} + (pattern-vars '((a b) ...))))) + (t/deftest unify-test - (t/is (= '{x (1 2 3)} - (sut/unify* 'x '(1 2 3)))) - (t/is (= '{x 1 y 2} - (sut/unify* '(x y) '(1 2)))) - (t/testing "literals" + (t/testing "variable" + (t/is (= '{x (1 2 3)} + (sut/unify* 'x '(1 2 3))))) + (t/testing "wildcard" + (t/is (= {} + (sut/unify* '_ '(1 2 3)))) + (t/is (= {} + (sut/unify* '(_ _) '(1 2)))) + (t/is (= nil + (sut/unify* '(_ _ _) '(1 2))))) + (t/testing "constants" (t/is (= {} (sut/unify* 123 123))) (t/is (= nil @@ -18,18 +56,32 @@ (sut/unify* true 456))) (t/is (= {} (sut/unify* true true)))) - (t/is (= '{x [:ellipsis (1 2 3 4)]} - (sut/unify* '(x ...) '(1 2 3 4)))) - (t/is (= '{x [:ellipsis (1 3)] - y [:ellipsis (2 4)]} - (sut/unify* '((x y) ...) '((1 2) (3 4))))) - (t/is (= nil - (sut/unify* '(x y z) '(1 2)))) - (t/is (= nil - (sut/unify* '(x y) '(1 2 3)))) - (t/is (= nil - (sut/unify* '((x y) ...) - '((1 2) (1 2 3))))) + (t/testing "known-length lists" + (t/is (= '{x 1 y 2} + (sut/unify* '(x y) '(1 2)))) + (t/is (= nil + (sut/unify* '(x y z) '(1 2)))) + (t/is (= nil + (sut/unify* '(x y) '(1 2 3)))) + (t/is (= '{a 1 b 2 c 3 d 4 e 5} + (sut/unify* '((a b) (c d e)) '((1 2) (3 4 5)))))) + (t/testing "trailing ellipsis" + (t/is (= '{x [:ellipsis (1 2 3 4)]} + (sut/unify* '(x ...) '(1 2 3 4)))) + (t/is (= '{x [:ellipsis (1 3)] + y [:ellipsis (2 4)]} + (sut/unify* '((x y) ...) '((1 2) (3 4))))) + (t/is (= nil + (sut/unify* '((x y) ...) + '((1 2) (1 2 3))))) + (t/testing "ellipsis matches empty list" + (t/is (= '{x [:ellipsis ()]} + (sut/unify* '(x ...) + '()))) + (t/is (= '{x [:ellipsis ()] + y [:ellipsis ()]} + (sut/unify* '((x y) ...) + '()))))) (t/is (= '{x (1 2 3)} (sut/unify* 'x '(1 2 3)))) (t/is (= '{x [:ellipsis (1 2 3)]}