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))))
+
 
 
 #_

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

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)