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))