From 390fe16d900ea28d6077a83e79822e0269dc0985 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 24 Sep 2026 05:48:40 -0600 Subject: [PATCH] --- src/common.clj | 9 +++++ src/expand.clj | 10 ++---- src/expand/syntax_rules.clj | 47 ++++++++++++++++++++++---- src/scm.clj | 7 +++- test/expand/syntax_rules_test.clj | 55 +++++++++++++++---------------- 5 files changed, 84 insertions(+), 44 deletions(-) create mode 100644 src/common.clj diff --git a/src/common.clj b/src/common.clj new file mode 100644 index 0000000..49cf2be --- /dev/null +++ b/src/common.clj @@ -0,0 +1,9 @@ +(ns common) + +(defmacro inherit [& syms] + (let [f (if (<= 8 (count syms)) + `hash-map + `array-map)] + `(~f ~@(mapcat #(list (keyword %) %) + syms)))) + diff --git a/src/expand.clj b/src/expand.clj index 2fbd568..e625a8a 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -7,14 +7,8 @@ [spec-dict.main :refer [dict]] [scm] [clojure.java.io :as io] - [expand.syntax-rules :as syntax-rules])) - -(defmacro inherit [& syms] - (let [f (if (<= 8 (count syms)) - `hash-map - `array-map)] - `(~f ~@(mapcat #(list (keyword %) %) - syms)))) + [expand.syntax-rules :as syntax-rules]) + (:use [common])) (s/def ::scope scm/scope?) diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj index 2274c44..6c2fb73 100644 --- a/src/expand/syntax_rules.clj +++ b/src/expand/syntax_rules.clj @@ -3,7 +3,9 @@ [clojure.spec.alpha :as s] [spec-dict.main :refer [dict]] [scm] - [clojure.test :as t])) + [clojure.test :as t] + [clojure.walk :as walk]) + (:use [common])) (s/def ::pattern scm/datum?) (s/def ::template scm/datum?) @@ -100,9 +102,40 @@ ;; 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 점점점")))) +(defn unify* [pattern datum] + (some-> (unify (scm/datum->syntax-recursive pattern) + (scm/datum->syntax-recursive datum)) + (update-vals scm/syntax->datum))) + +(defn transcribe [template unification] + (match (scm/syntax-e template) + (x :guard symbol?) (or (get unification x) + (throw (Exception. "blah"))) + ([x & xs] :seq) + (let [xs* (transcribe (scm/datum->syntax xs template) unification)] + (scm/datum->syntax + (cons (transcribe x unification) (scm/syntax-e xs*)) + template)) + + ([] :seq) + template)) + +(defn transcribe* + ([template unification] + (-> template + scm/datum->syntax-recursive + (transcribe unification))) + ([template pattern datum] + (-> (transcribe (scm/datum->syntax-recursive template) + (unify (scm/datum->syntax-recursive pattern) + (scm/datum->syntax-recursive datum))) + scm/syntax->datum))) + +(comment + (let [pattern 'x + template 'x + datum '(1 2 3)] + (-> template + (transcribe* (unify (scm/datum->syntax-recursive pattern) + (scm/datum->syntax-recursive datum))) + #_scm/syntax->datum))) diff --git a/src/scm.clj b/src/scm.clj index 8595b2d..5f15072 100644 --- a/src/scm.clj +++ b/src/scm.clj @@ -104,7 +104,12 @@ (declare constant?) (defn syntax->datum [stx] - (cond (syntax? stx) (recur (syntax-e stx)) + (walk/prewalk + #(if (syntax? %) + (syntax-e %) + %) + stx) + #_(cond (syntax? stx) (recur (syntax-e stx)) (seq? stx) (map syntax->datum stx) (improper-list? stx) (throw (Exception. "todo")) (or (constant? stx) (symbol? stx)) stx diff --git a/test/expand/syntax_rules_test.clj b/test/expand/syntax_rules_test.clj index 7688888..da0d52d 100644 --- a/test/expand/syntax_rules_test.clj +++ b/test/expand/syntax_rules_test.clj @@ -4,42 +4,41 @@ [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)} - (unify 'x '(1 2 3)))) + (sut/unify* 'x '(1 2 3)))) (t/is (= '{x 1 y 2} - (unify '(x y) '(1 2)))) + (sut/unify* '(x y) '(1 2)))) (t/is (= '{x [:ellipsis (1 2 3 4)]} - (unify '(x ...) '(1 2 3 4)))) + (sut/unify* '(x ...) '(1 2 3 4)))) (t/is (= '{x [:ellipsis (1 3)] y [:ellipsis (2 4)]} - (unify '((x y) ...) '((1 2) (3 4))))) + (sut/unify* '((x y) ...) '((1 2) (3 4))))) (t/is (= nil - (unify '(x y z) '(1 2)))) + (sut/unify* '(x y z) '(1 2)))) (t/is (= nil - (unify '((x y) ...) + (sut/unify* '(x y) '(1 2 3)))) + (t/is (= nil + (sut/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) ...) + (sut/unify* 'x '(1 2 3)))) + (t/is (= '{x [:ellipsis (1 2 3)]} + (sut/unify* '(x ...) '(1 2 3)))) + (t/is (= '{x 1 + y [:ellipsis (2 3)]} + (sut/unify* '(x y ...) '(1 2 3)))) + (t/is (= '{x 1 y 2} + (sut/unify* '(x y) '(1 2)))) + (t/is (= '{x [:ellipsis (1 3)] + y [:ellipsis (2 4)]} + (sut/unify* '((x y) ...) '((1 2) (3 4)))))) + +(t/deftest transcribe-test + (t/is (= 123 + (sut/transcribe* 'x 'x 123))) + (t/is (= 4 + (sut/transcribe* 'x '(x y) '(4 5)))) + (t/is (= '(3 2 1) + (sut/transcribe* '(z y x) '(x y z) '(1 2 3)))))