src/expand.clj

@@ -43,7 +43,12 @@
         :list (s/and (s/* ::template-element) sequential?)))
 
 (s/def ::template-element
-  (s/cat :template ::template :ellipsis (s/? #{'...})))
+  (s/& (s/cat :template ::template :ellipsis (s/? #{'...}))
+       (s/conformer
+          (fn [{:keys [ellipsis template]}]
+            (if ellipsis
+              [:ellipsis template]
+              template)))))
 
 (s/def ::rule
   (s/and sequential?
@@ -112,9 +117,6 @@
       nil
       xs*)))
 
-(defn unify [pattern datum]
-  (unify* (s/conform ::pattern pattern) datum))
-
 (defn- unify* [pattern datum]
   (match [pattern datum]
     [[:var x] _]
@@ -143,12 +145,50 @@
      (_ :guard seq?)]
     (and (= (count datum)
             (count leading))
-         (->> (map #(unify* depth %1 %2) leading datum)
+         (->> (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)))
+              '((a ...) ...)))
+
+(defn transcribe* [depth index unification template]
+  (match template
+    [:var x]
+    (match (get unification x)
+      [:ellipsis p]
+      (if (< 0 depth)
+        (if (seq? p)
+          (recur (dec depth) index
+                 (assoc unification x
+                        (nth p index))))
+          (throw (ex-info "ellipsis bad" {})))
+
+      (_ :guard nil?)
+      #_(throw (ex-info "unbound" {:symbol x}))
+      x ;; unhygenic but it's demo }:)
+
+      p p)
+
+    [:list ts]
+    (->> (for [[i t] (map-indexed (fn [i x] [i x]) ts)]
+           (match t
+             [:ellipsis t*] (transcribe* (inc depth) i unification t*)
+             :else [(transcribe* depth i unification t)]))
+         (apply concat))))
+
+(defn transcribe [unification template]
+  (transcribe* 0 0 unification (s/conform ::template template)))
+
 
 
 (defn symtable-for-env [env]

test/expand_test.clj

@@ -33,7 +33,7 @@
       '... '(...) '(... a b c)
       '(a ... b ...)))
   (t/testing "simple data"
-    (t/is (= 'a (sut/conform ::patern 'a)))))
+    (t/is (= 'a (s/conform ::patern 'a)))))
 
 (t/deftest expand-test
   (t/testing "unbound symbol"
@@ -71,7 +71,13 @@
 (t/deftest template-spec
   (t/is (s/valid? ::sut/template '(x ... y)))
   (t/is (s/valid? ::sut/template 123))
-  (t/is (s/valid? ::sut/template '(x y ... z ... a b c))))
+  (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))))
@@ -88,4 +94,17 @@
 (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))
+    nil '(a b) 123
+
+    '{b [:ellipsis ([:ellipsis (1 2)] [:ellipsis (3 4)])]}
+    '((b ...) ...)
+    '((1 2) (3 4))))
+
+(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 ...)))