diff --git a/src/expand.clj b/src/expand.clj index e7c80d1..2fbd568 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -6,7 +6,8 @@ [clojure.walk] [spec-dict.main :refer [dict]] [scm] - [clojure.java.io :as io])) + [clojure.java.io :as io] + [expand.syntax-rules :as syntax-rules])) (defmacro inherit [& syms] (let [f (if (<= 8 (count syms)) @@ -114,6 +115,8 @@ :kind sequential?)) :body ::body))) +(s/def ::prim-let-syntax ::prim-let) + (s/def ::prim-if (s/and ::unsyntax (s/cat :keyword ::identifier @@ -121,6 +124,13 @@ :consequent ::datum :alternative ::datum))) +;; cf. `::transformer` +(s/def ::prim-syntax-rules + (s/and seq? (s/cat :keyword ::identifier + :keywords (s/and ::unsyntax + (s/coll-of ::identifier)) + :rules (s/* ::datum)))) + #_ diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj index f2a7b74..2274c44 100644 --- a/src/expand/syntax_rules.clj +++ b/src/expand/syntax_rules.clj @@ -1,26 +1,12 @@ (ns expand.syntax-rules (:require [clojure.core.match :refer [match]] [clojure.spec.alpha :as s] - [scm])) + [spec-dict.main :refer [dict]] + [scm] + [clojure.test :as t])) -(s/def ::pattern - (s/or :wildcard #{'_} - :var (s/and symbol? (complement #{'... '_})) - :lit scm/constant? - :list (s/and seq? - (s/cat :leading (s/* ::pattern) - :rest (s/? (s/cat :ellipsis #{'...} - :trailing (s/* ::pattern)))) - (s/conformer - (fn [pat] - (if-some [{:keys [ellipsis trailing]} (:rest pat)] - (let [{:keys [leading]} pat] - (if-some [variadic (last leading)] - {:leading (vec (butlast leading)) - :ellipsis variadic - :trailing trailing} - ::s/invalid)) - pat)))))) +(s/def ::pattern scm/datum?) +(s/def ::template scm/datum?) (defn- report-conflict [x y] (throw (ex-info "너무 정의합니다" @@ -35,6 +21,7 @@ (defn- merge-unify [& xs] (apply merge-unify-with report-conflict xs)) +#_ (defn- unify* [pattern datum] (match [pattern datum] [[:wildcard _] _] {} @@ -67,15 +54,55 @@ ;; no match :else nil)) +#_ (defn unify [pattern datum] (unify* (s/conform ::pattern pattern) datum)) +(defn wildcard? [x] + (or (= '_ x) + (and (scm/syntax? x) (-> x scm/syntax-e wildcard?)))) + +(defn ellipsis? [x] + (or (= '... x) + (and (scm/syntax? x) (-> x scm/syntax-e ellipsis?)))) + +(defn unify [pattern datum] + (match [(scm/syntax-e pattern) (scm/syntax-e datum)] + [(_ :guard wildcard?) _] {} + [(x :guard symbol?) _] {x datum} + + [([p (_ :guard ellipsis?) & ps] :seq) + (ds :guard seq?)] + (let [ds-end (take-last (count ps) ds) + ds-start (drop-last (count ps) ds)] + (merge-unify + (some->> ds + (map #(some-> (unify p %) + (update-vals list))) + (apply merge-unify-with concat) + (map (fn [[k v]] + [k [:ellipsis v]])) + (into {})))) + + [([p & ps] :seq) + ([d & ds] :seq)] + (merge-unify (unify p d) + (unify (scm/datum->syntax ps pattern) + (scm/datum->syntax ds datum))) + [([] :seq) + ([] :seq)] + {} + + [(_ :guard scm/constant?) + (_ :guard scm/constant?)] + (when (= pattern datum) {}) + + ;; no match + :else nil)) + (defn transcribe [template] (match template [:var x] (throw (Exception. "todo")) [:ellipsis _] (throw (Exception. "todo 점점점")) [:lit x] (throw (Exception. "todo 점점점")) [:list xs] (throw (Exception. "todo 점점점")))) - -(comment - (unify 'x '(1 2 3))) diff --git a/src/scm.clj b/src/scm.clj index 0e041de..8595b2d 100644 --- a/src/scm.clj +++ b/src/scm.clj @@ -4,7 +4,8 @@ [clojure.java.io :as io] [clojure.pprint] [instaparse.core :as insta] - [clojure.spec.alpha :as s]) + [clojure.spec.alpha :as s] + [clojure.walk :as walk]) (:import (clojure.lang ILookup IReduce IReduceInit))) @@ -35,6 +36,9 @@ clojure.lang.IPersistentCollection (count [_] 2) (cons [this o] (cons o (seq this))) + (equiv [this other] + (and (seqable? other) + (.equiv (seq this) (seq other)))) ;; 진짜 나쁘다ㅋㅋㅋㅋ. 이러니까 `clojure.walk/walk`로 쓰다. clojure.lang.IRecord) @@ -88,8 +92,17 @@ (assert (not (syntax? datum)) "너는 이렇고 싶은가…") (->Syntax datum (syntax-context ctxt-donor)))) +(defn datum->syntax-recursive + ([datum] + (assert (not (syntax? datum)) "너는 이렇고 싶은가…") + (walk/postwalk (fn [x] + (->Syntax x nil)) + datum))) + (declare improper-list?) +(declare constant?) + (defn syntax->datum [stx] (cond (syntax? stx) (recur (syntax-e stx)) (seq? stx) (map syntax->datum stx) diff --git a/test/expand/syntax_rules_test.clj b/test/expand/syntax_rules_test.clj index fd5ed94..7688888 100644 --- a/test/expand/syntax_rules_test.clj +++ b/test/expand/syntax_rules_test.clj @@ -1,23 +1,45 @@ (ns expand.syntax-rules-test (:require [expand.syntax-rules :as sut] - [clojure.test :as t])) + [clojure.core.match :refer [match]] + [clojure.test :as t] + [clojure.walk :as walk])) + +(defn- unify [pattern datum] + (some-> (sut/unify (scm/datum->syntax-recursive pattern) + (scm/datum->syntax-recursive datum)) + (update-vals + (fn [unif] + (walk/prewalk + #(if (scm/syntax? %) + (scm/syntax-e %) + %) + unif))))) (t/deftest unify-test (t/is (= '{x (1 2 3)} - (sut/unify 'x '(1 2 3)))) + (unify 'x '(1 2 3)))) (t/is (= '{x 1 y 2} - (sut/unify '(x y) - '(1 2)))) + (unify '(x y) '(1 2)))) (t/is (= '{x [:ellipsis (1 2 3 4)]} - (sut/unify '(x ...) - '(1 2 3 4)))) + (unify '(x ...) '(1 2 3 4)))) (t/is (= '{x [:ellipsis (1 3)] y [:ellipsis (2 4)]} - (sut/unify '((x y) ...) - '((1 2) (3 4))))) + (unify '((x y) ...) '((1 2) (3 4))))) (t/is (= nil - (sut/unify '(x y z) - '(1 2)))) + (unify '(x y z) '(1 2)))) (t/is (= nil - (sut/unify '((x y) ...) - '((1 2) (1 2 3)))))) + (unify '((x y) ...) + '((1 2) (1 2 3))))) + (t/is (= '{x (1 2 3)} + (unify 'x '(1 2 3)))) + (t/is (= {'x [:ellipsis '(1 2 3)]} + (unify '(x ...) '(1 2 3)))) + (t/is (= {'x 1 + 'y [:ellipsis '(2 3)]} + (unify '(x y ...) '(1 2 3)))) + (t/is (= {'x 1 'y 2} + (unify '(x y) '(1 2)))) + (t/is (= {'x [:ellipsis '(1 3)] + 'y [:ellipsis '(2 4)]} + (unify '((x y) ...) + '((1 2) (3 4))))))