diff --git a/src/expand.clj b/src/expand.clj index 905716b..625230b 100644 --- a/src/expand.clj +++ b/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] diff --git a/src/unhygienic.clj b/src/unhygienic.clj new file mode 100644 index 0000000..fcaa6a0 --- /dev/null +++ b/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))) diff --git a/test/expand_test.clj b/test/expand_test.clj index 4889d81..2da0828 100644 --- a/test/expand_test.clj +++ b/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 ...) ...))) diff --git a/test/unhygienic_test.clj b/test/unhygienic_test.clj new file mode 100644 index 0000000..dc62699 --- /dev/null +++ b/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 ...) ...)))