unifyish

src/expand.clj

@@ -16,19 +16,9 @@
      [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
      [:global sym] (symbol? sym)))
 
-(defn- parse-pattern-list [pat]
-  (loop [xs pat
-         acc {:type :list :leading []}]
-    (match xs
-      ([x '... & ys] :seq) (-> acc
-                               (assoc :ellipsis x :trailing (seq ys))
-                               (update :leading seq))
-      ([] :seq) (update acc :leading seq)
-      ([x & ys] :seq) (recur ys (update acc :leading #(conj % x))))))
-
 (s/def ::pattern
   (s/or :var (s/and symbol?
-                    #(not= '... %))
+                    (comp not #{'... '_}))
         :lit ::literal
         :list (s/and seq?
                      (s/cat :leading (s/* ::pattern)
@@ -43,16 +33,7 @@
                                :ellipsis variadic
                                :trailing trailing}
                               ::s/invalid))
-                          pat)))))
-  #_(s/conformer
-   (fn go [pat]
-     (cond (seq? pat)
-           (-> (parse-pattern-list pat)
-               (update :leading #(map go %))
-               (update :ellipsis #(some-> % go))
-               (update :trailing #(map go %)))
-           (symbol? pat) pat
-           :else ::s/invalid))))
+                          pat))))))
 
 (s/def ::literal (some-fn string? boolean? number? char?))
 
@@ -110,25 +91,63 @@
 (s/def ::prim-let-syntax ::prim-let)
 
 (s/def ::prim-syntax-rules
-  (s/cat :keyword symbol
+  (s/cat :keyword symbol?
          :keywords (s/coll-of symbol?)
          :rules (s/* ::rule)))
 
-(defn parse-pattern [pat]
-  (cond (seq? pat)
-        (loop [xs pat
-               acc {:type :list :leading []}]
-          (match xs
-            ([x '... & ys] :seq) (-> acc
-                                     (assoc :ellipsis x :trailing (seq ys))
-                                     (update :leading seq))
-            ([] :seq) (update acc :leading seq)
-            ([x & ys] :seq) (recur ys (update acc :leading #(conj % x)))))
-        (symbol? pat) pat))
-
 
 
+(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]
+  (unify* (s/conform ::pattern pattern) datum))
+
+(defn- unify* [pattern datum]
+  (match [pattern datum]
+    [[: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?)]
+    (and (= (count datum)
+            (count leading))
+         (->> (map #(unify* depth %1 %2) leading datum)
+              (apply merge-unify)))
+
+    ;; no match
+    :else nil))
 
 
 

test/expand_test.clj

@@ -28,9 +28,12 @@
       '(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)))
+      '(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 (sut/parse-pattern 'a)))))
+    (t/is (= 'a (sut/conform ::patern 'a)))))
 
 (t/deftest expand-test
   (t/testing "unbound symbol"
@@ -81,3 +84,8 @@
                   '(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))