split out unhygienic toy model

src/expand.clj

@@ -110,118 +110,6 @@
 
 
 
-(defn- merge-unify-with
-  ([f] {})
-  ([f a] a)
-  ([f a b] (and a b (merge-with f a b)))
-  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))
-
-(defn- merge-unify [& xs]
-  (apply merge-unify-with (fn [_ x] x) xs))
-
-(defn traverse [f xs]
-  (let [xs* (map f xs)]
-    (if (contains? xs* nil)
-      nil
-      xs*)))
-
-(defn- unify* [pattern datum]
-  (match [pattern datum]
-    [[:wildcard _] _] {}
-    [[:var x] _] {x datum}
-    
-    [[:list {:leading leading
-             :trailing nil
-             :ellipsis ellipsis}]
-     (_ :guard seq?)]
-    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
-      (merge-unify
-       (apply merge-unify (map #(unify* %1 %2)
-                               leading
-                               leading-datum))
-       (some->> ellipsis-datum
-                (map #(when-some [r (unify* ellipsis %)]
-                        (->> r
-                             (map (fn [[k v]] [k (list v)]))
-                             (into {}))))
-                (apply merge-unify-with concat)
-                (map (fn [[k v]]
-                       [k [:ellipsis v]]))
-                (into {}))))
-
-    [[:list {:leading leading}]
-     (_ :guard seq?)]
-    (when (= (count datum)
-             (count leading))
-      (->> (map #(unify* %1 %2) leading datum)
-           (apply merge-unify)))
-
-    ;; no match
-    :else nil))
-
-(defn unify [pattern datum]
-  (unify* (s/conform ::pattern pattern) datum))
-
-
-
-(comment
-  (transcribe (unify '((a ...) ...)
-                     '((1 2) (3 4) (5 6)))
-              '(begin (a ...) ...))
-  (strip-ellipsis
-   '[:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)] [:ellipsis (5 6)])]
-   2))
-
-(defn- strip-ellipsis [unif ellipsis-depth]
-  (match unif
-    [:ellipsis p]
-    (if (< 0 ellipsis-depth)
-      (map #(strip-ellipsis % (dec ellipsis-depth)) p)
-      (throw (ex-info "나쁜 점점점" {})))
-    :else unif))
-
-(defn- transcribe*
-  ([unification template]
-   (transcribe* 0 unification template))
-  ([ellipsis-depth unification template]
-   (match template
-     [:lit l] l
-
-     [:var x]
-     (match (get unification x)
-       ([:ellipsis _] :as p)
-       (strip-ellipsis p ellipsis-depth)
-
-       (_ :guard nil?)
-       #_(throw (ex-info "unbound" {:symbol x}))
-       x ;; unhygenic but it's demo }:)
-
-       p p)
-
-     [:list ts]
-     (do #_ #dbg (+ 0 0)
-         (->> (for [t ts]
-                (match t
-                  [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
-                  :else [(transcribe* ellipsis-depth unification t)]))
-              (apply concat))))))
-
-(defn transcribe [unification template]
-  (transcribe* 0 unification (s/conform ::template template)))
-
-(comment
-  (transcribe-transformer scheme-and '(and 1 2)))
-
-(defn transcribe-transformer [trans datum]
-  (some (fn [{:keys [pattern template]}]
-          (when-some [unification (unify* pattern datum)]
-            (let [r (transcribe* unification template)]
-              (assert r)
-              r)))
-        (:rules trans)))
-
-
-
 (defn symtable-for-env [env]
   (into {}
         (for [[[_ x] _] env]

src/unhygienic.clj

@@ -0,0 +1,106 @@
+(ns unhygienic
+  (:require [clojure.core.match :refer [match]]
+            [clojure.spec.alpha :as s]
+            [expand]))
+
+(defn- merge-unify-with
+  ([f] {})
+  ([f a] a)
+  ([f a b] (and a b (merge-with f a b)))
+  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))
+
+(defn- merge-unify [& xs]
+  (apply merge-unify-with (fn [_ x] x) xs))
+
+(defn- unify* [pattern datum]
+  (match [pattern datum]
+    [[:wildcard _] _] {}
+    [[:var x] _] {x datum}
+    
+    [[:list {:leading leading
+             :trailing nil
+             :ellipsis ellipsis}]
+     (_ :guard seq?)]
+    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
+      (merge-unify
+       (apply merge-unify (map #(unify* %1 %2)
+                               leading
+                               leading-datum))
+       (some->> ellipsis-datum
+                (map #(when-some [r (unify* ellipsis %)]
+                        (->> r
+                             (map (fn [[k v]] [k (list v)]))
+                             (into {}))))
+                (apply merge-unify-with concat)
+                (map (fn [[k v]]
+                       [k [:ellipsis v]]))
+                (into {}))))
+
+    [[:list {:leading leading}]
+     (_ :guard seq?)]
+    (when (= (count datum)
+             (count leading))
+      (->> (map #(unify* %1 %2) leading datum)
+           (apply merge-unify)))
+
+    ;; no match
+    :else nil))
+
+(defn unify [pattern datum]
+  (unify* (s/conform :expand/pattern pattern) datum))
+
+
+
+(comment
+  (transcribe (unify '((a ...) ...)
+                     '((1 2) (3 4) (5 6)))
+              '(begin (a ...) ...))
+  (strip-ellipsis
+   '[:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)] [:ellipsis (5 6)])]
+   2))
+
+(defn- strip-ellipsis [unif ellipsis-depth]
+  (match unif
+    [:ellipsis p]
+    (if (< 0 ellipsis-depth)
+      (map #(strip-ellipsis % (dec ellipsis-depth)) p)
+      (throw (ex-info "나쁜 점점점" {})))
+    :else unif))
+
+(defn- transcribe*
+  ([unification template]
+   (transcribe* 0 unification template))
+  ([ellipsis-depth unification template]
+   (match template
+     [:lit l] l
+
+     [:var x]
+     (match (get unification x)
+       ([:ellipsis _] :as p)
+       (strip-ellipsis p ellipsis-depth)
+
+       ;; unhygenic but it's demo }:)
+       (_ :guard nil?) x
+
+       p p)
+
+     [:list ts]
+     (->> (for [t ts]
+            (match t
+              [:ellipsis t*] (transcribe* (inc ellipsis-depth) unification t*)
+              :else [(transcribe* ellipsis-depth unification t)]))
+          (apply concat)))))
+
+(defn transcribe [unification template]
+  (transcribe* 0 unification (s/conform :expand/template template)))
+
+(comment
+  (transcribe-transformer scheme-and '(and 1 2)))
+
+(defn transcribe-transformer [trans datum]
+  (some (fn [{:keys [pattern template]}]
+          (when-some [unification (unify* pattern datum)]
+            (let [r (transcribe* unification template)]
+              (assert r)
+              r)))
+        (:rules trans)))

test/expand_test.clj

@@ -104,30 +104,3 @@
                   '(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))))
-
-(t/deftest transcribe-test
-  (t/are [result datum pattern template]
-      (= result (sut/transcribe (sut/unify pattern datum) template))
-    '(1 a 2 b) '((1 2) (a b))
-    '((x y) ...) '(x ... y ...)
-
-    '(1 2 3 4) '(1 2 3 4)
-    '(x ...) '(x ...)
-
-    '(concat (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))
-    '((a ...) ...) '(concat (a ...) ...)))

test/unhygienic_test.clj

@@ -0,0 +1,30 @@
+(ns unhygienic-test
+  (:require [unhygienic :as sut]
+            [clojure.test :as t]))
+
+(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))))
+
+(t/deftest transcribe-test
+  (t/are [result datum pattern template]
+      (= result (sut/transcribe (sut/unify pattern datum) template))
+    '(1 a 2 b) '((1 2) (a b))
+    '((x y) ...) '(x ... y ...)
+
+    '(1 2 3 4) '(1 2 3 4)
+    '(x ...) '(x ...)
+
+    '(concat (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))
+    '((a ...) ...) '(concat (a ...) ...)))