src/common.clj

@@ -0,0 +1,9 @@
+(ns common)
+
+(defmacro inherit [& syms]
+  (let [f (if (<= 8 (count syms))
+            `hash-map
+            `array-map)]
+    `(~f ~@(mapcat #(list (keyword %) %)
+                   syms))))
+

src/expand.clj

@@ -7,14 +7,8 @@
             [spec-dict.main :refer [dict]]
             [scm]
             [clojure.java.io :as io]
-            [expand.syntax-rules :as syntax-rules]))
-
-(defmacro inherit [& syms]
-  (let [f (if (<= 8 (count syms))
-            `hash-map
-            `array-map)]
-    `(~f ~@(mapcat #(list (keyword %) %)
-                   syms))))
+            [expand.syntax-rules :as syntax-rules])
+  (:use [common]))
 
 (s/def ::scope scm/scope?)
 

src/expand/syntax_rules.clj

@@ -3,7 +3,9 @@
             [clojure.spec.alpha :as s]
             [spec-dict.main :refer [dict]]
             [scm]
-            [clojure.test :as t]))
+            [clojure.test :as t]
+            [clojure.walk :as walk])
+  (:use [common]))
 
 (s/def ::pattern scm/datum?)
 (s/def ::template scm/datum?)
@@ -100,9 +102,40 @@
     ;; no match
     :else nil))
 
-(defn transcribe [template]
-  (match template
-    [:var x] (throw (Exception. "todo"))
-    [:ellipsis _] (throw (Exception. "todo 점점점"))
-    [:lit x] (throw (Exception. "todo 점점점"))
-    [:list xs] (throw (Exception. "todo 점점점"))))
+(defn unify* [pattern datum]
+  (some-> (unify (scm/datum->syntax-recursive pattern)
+                 (scm/datum->syntax-recursive datum))
+          (update-vals scm/syntax->datum)))
+
+(defn transcribe [template unification]
+  (match (scm/syntax-e template)
+    (x :guard symbol?) (or (get unification x)
+                           (throw (Exception. "blah")))
+    ([x & xs] :seq)
+    (let [xs* (transcribe (scm/datum->syntax xs template) unification)]
+      (scm/datum->syntax
+       (cons (transcribe x unification) (scm/syntax-e xs*))
+       template))
+
+    ([] :seq)
+    template))
+
+(defn transcribe*
+  ([template unification]
+   (-> template
+       scm/datum->syntax-recursive
+       (transcribe unification)))
+  ([template pattern datum]
+   (-> (transcribe (scm/datum->syntax-recursive template)
+                   (unify (scm/datum->syntax-recursive pattern)
+                          (scm/datum->syntax-recursive datum)))
+       scm/syntax->datum)))
+
+(comment
+  (let [pattern 'x
+        template 'x
+        datum '(1 2 3)]
+    (-> template
+        (transcribe* (unify (scm/datum->syntax-recursive pattern)
+                            (scm/datum->syntax-recursive datum)))
+        #_scm/syntax->datum)))

src/scm.clj

@@ -104,7 +104,12 @@
 (declare constant?)
 
 (defn syntax->datum [stx]
-  (cond (syntax? stx) (recur (syntax-e stx))
+  (walk/prewalk
+   #(if (syntax? %)
+      (syntax-e %)
+      %)
+   stx)
+  #_(cond (syntax? stx) (recur (syntax-e stx))
         (seq? stx) (map syntax->datum stx)
         (improper-list? stx) (throw (Exception. "todo"))
         (or (constant? stx) (symbol? stx)) stx

test/expand/syntax_rules_test.clj

@@ -4,42 +4,41 @@
             [clojure.test :as t]
             [clojure.walk :as walk]))
 
-(defn- unify [pattern datum]
-  (some-> (sut/unify (scm/datum->syntax-recursive pattern)
-                     (scm/datum->syntax-recursive datum))
-          (update-vals
-           (fn [unif]
-             (walk/prewalk
-              #(if (scm/syntax? %)
-                 (scm/syntax-e %)
-                 %)
-              unif)))))
-
 (t/deftest unify-test
   (t/is (= '{x (1 2 3)}
-           (unify 'x '(1 2 3))))
+           (sut/unify* 'x '(1 2 3))))
   (t/is (= '{x 1 y 2}
-           (unify '(x y) '(1 2))))
+           (sut/unify* '(x y) '(1 2))))
   (t/is (= '{x [:ellipsis (1 2 3 4)]}
-           (unify '(x ...) '(1 2 3 4))))
+           (sut/unify* '(x ...) '(1 2 3 4))))
   (t/is (= '{x [:ellipsis (1 3)]
              y [:ellipsis (2 4)]}
-           (unify '((x y) ...) '((1 2) (3 4)))))
+           (sut/unify* '((x y) ...) '((1 2) (3 4)))))
   (t/is (= nil
-           (unify '(x y z) '(1 2))))
+           (sut/unify* '(x y z) '(1 2))))
   (t/is (= nil
-           (unify '((x y) ...)
+           (sut/unify* '(x y) '(1 2 3))))
+  (t/is (= nil
+           (sut/unify* '((x y) ...)
                   '((1 2) (1 2 3)))))
   (t/is (= '{x (1 2 3)}
-           (unify 'x '(1 2 3))))
-  (t/is (= {'x [:ellipsis '(1 2 3)]}
-           (unify '(x ...) '(1 2 3))))
-  (t/is (= {'x 1
-            'y [:ellipsis '(2 3)]}
-           (unify '(x y ...) '(1 2 3))))
-  (t/is (= {'x 1 'y 2}
-           (unify '(x y) '(1 2))))
-  (t/is (= {'x [:ellipsis '(1 3)]
-            'y [:ellipsis '(2 4)]}
-           (unify '((x y) ...)
+           (sut/unify* 'x '(1 2 3))))
+  (t/is (= '{x [:ellipsis (1 2 3)]}
+           (sut/unify* '(x ...) '(1 2 3))))
+  (t/is (= '{x 1
+             y [:ellipsis (2 3)]}
+           (sut/unify* '(x y ...) '(1 2 3))))
+  (t/is (= '{x 1 y 2}
+           (sut/unify* '(x y) '(1 2))))
+  (t/is (= '{x [:ellipsis (1 3)]
+             y [:ellipsis (2 4)]}
+           (sut/unify* '((x y) ...)
                   '((1 2) (3 4))))))
+
+(t/deftest transcribe-test
+  (t/is (= 123
+           (sut/transcribe* 'x 'x 123)))
+  (t/is (= 4
+           (sut/transcribe* 'x '(x y) '(4 5))))
+  (t/is (= '(3 2 1)
+           (sut/transcribe* '(z y x) '(x y z) '(1 2 3)))))