From ac128356c200ef561e714fb0cbe7750b5599cc8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 24 Sep 2026 08:52:31 -0600 Subject: [PATCH] =?UTF-8?q?=EC=B2=AD=EC=86=8C?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- {src => resources/expand/scm}/r7rs.ebnf | 0 src/data_readers.clj | 2 +- src/{ => expand}/common.clj | 2 +- src/{expand.clj => expand/core.clj} | 16 +- src/{ => expand}/scm.clj | 6 +- src/expand/syntax_rules.clj | 73 +-- src/old.clj | 593 ------------------ src/unhygienic.clj | 106 ---- .../{expand_test.clj => expand/core_test.clj} | 11 +- test/{ => expand}/scm_test.clj | 12 +- test/expand/syntax_rules_test.clj | 3 +- test/old_test.clj | 152 ----- test/unhygienic_test.clj | 30 - 13 files changed, 36 insertions(+), 970 deletions(-) rename {src => resources/expand/scm}/r7rs.ebnf (100%) rename src/{ => expand}/common.clj (97%) rename src/{expand.clj => expand/core.clj} (97%) rename src/{ => expand}/scm.clj (98%) delete mode 100644 src/old.clj delete mode 100644 src/unhygienic.clj rename test/{expand_test.clj => expand/core_test.clj} (95%) rename test/{ => expand}/scm_test.clj (90%) delete mode 100644 test/old_test.clj delete mode 100644 test/unhygienic_test.clj diff --git a/src/r7rs.ebnf b/resources/expand/scm/r7rs.ebnf similarity index 100% rename from src/r7rs.ebnf rename to resources/expand/scm/r7rs.ebnf diff --git a/src/data_readers.clj b/src/data_readers.clj index 89545d7..4a69014 100644 --- a/src/data_readers.clj +++ b/src/data_readers.clj @@ -1 +1 @@ -{scm/stx scm/stx-reader} +{scm/stx expand.scm/stx-reader} diff --git a/src/common.clj b/src/expand/common.clj similarity index 97% rename from src/common.clj rename to src/expand/common.clj index c8d5d5e..1641f53 100644 --- a/src/common.clj +++ b/src/expand/common.clj @@ -1,4 +1,4 @@ -(ns common) +(ns expand.common) (defmacro inherit [& syms] (let [f (if (<= 8 (count syms)) diff --git a/src/expand.clj b/src/expand/core.clj similarity index 97% rename from src/expand.clj rename to src/expand/core.clj index e625a8a..b314b64 100644 --- a/src/expand.clj +++ b/src/expand/core.clj @@ -1,14 +1,14 @@ -(ns expand +(ns expand.core (:require [clojure.core.match :refer [match]] + [clojure.java.io :as io] [clojure.pprint] [clojure.set :as set] [clojure.spec.alpha :as s] [clojure.walk] - [spec-dict.main :refer [dict]] - [scm] - [clojure.java.io :as io] - [expand.syntax-rules :as syntax-rules]) - (:use [common])) + [expand.common :refer :all] + [expand.scm :as scm] + [expand.syntax-rules :as syntax-rules] + [spec-dict.main :refer [dict]])) (s/def ::scope scm/scope?) @@ -329,7 +329,7 @@ :else decl))))) (comment - (-> "t.scm" + (-> "t.expand.scm" slurp (scm/read-syntax :library? true) expand-library @@ -338,7 +338,7 @@ (let [scopeholder (scm/new-scopeholder) env {[:global 'lambda] [:primitive 'lambda]} store-atom (atom {['lambda #{}] [:global 'lambda]})] - (expand (-> (slurp "t.scm") + (expand (-> (slurp "t.expand.scm") (scm/read-syntax #_#_:library? true) (scm/rescope scopeholder)) env store-atom))) diff --git a/src/scm.clj b/src/expand/scm.clj similarity index 98% rename from src/scm.clj rename to src/expand/scm.clj index 7441508..a45b416 100644 --- a/src/scm.clj +++ b/src/expand/scm.clj @@ -1,4 +1,4 @@ -(ns scm +(ns expand.scm (:refer-clojure :exclude [read]) (:require [clojure.core.match :refer [match]] [clojure.java.io :as io] @@ -27,7 +27,7 @@ (and (satisfies? ISyntax y) (.equals datum (syntax-e y)) (.equals ctx (syntax-context y))))) - scm/ISyntax + expand.scm/ISyntax (syntax-e [this] datum) (syntax-context [this] ctx) clojure.lang.Seqable @@ -169,7 +169,7 @@ ;;; r⁷rs reader -(insta/defparser r7rs-parser (io/resource "r7rs.ebnf")) +(insta/defparser r7rs-parser (io/resource "expand/scm/r7rs.ebnf")) (defn read "text에서 Scheme 데이텀 한 개를 받는다. diff --git a/src/expand/syntax_rules.clj b/src/expand/syntax_rules.clj index cd778c8..911717f 100644 --- a/src/expand/syntax_rules.clj +++ b/src/expand/syntax_rules.clj @@ -1,18 +1,18 @@ (ns expand.syntax-rules - (:require [clojure.core.match :refer [match]] - [clojure.spec.alpha :as s] - [spec-dict.main :refer [dict]] - [scm] - [clojure.test :as t] - [clojure.walk :as walk]) - (:use [common])) + (:require + [clojure.core.match :refer [match]] + [clojure.spec.alpha :as s] + [clojure.test :as t] + [clojure.walk :as walk] + [expand.common :refer :all] + [expand.scm :as scm] + [spec-dict.main :refer [dict]])) (s/def ::pattern scm/datum?) (s/def ::template scm/datum?) (defn- report-conflict [x y] - (throw (ex-info "너무 정의합니다" - {:x x :y y}))) + (throw (ex-info "정의는 너무 많다" {:x x :y y}))) (defn- merge-unify-with ([f] {}) @@ -23,43 +23,6 @@ (defn- merge-unify [& xs] (apply merge-unify-with report-conflict 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 #(some-> (unify* ellipsis %) - (update-vals list))) - (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)) - (defn wildcard? [x] (or (= '_ x) (and (scm/syntax? x) (-> x scm/syntax-e wildcard?)))) @@ -169,21 +132,3 @@ (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)) - (let [pattern '((x y ...) ...) - template '(x ...) - datum '((1 2) (3 4 5))] - (-> template - (transcribe* (unify (scm/datum->syntax-recursive pattern) - (scm/datum->syntax-recursive datum))) - #_scm/syntax->datum)) - (unify* '((x y ...) ...) - '((1 2 3) (3 4)))) diff --git a/src/old.clj b/src/old.clj deleted file mode 100644 index 222087c..0000000 --- a/src/old.clj +++ /dev/null @@ -1,593 +0,0 @@ -(ns old - (:require [clojure.core.match :refer [match]] - [clojure.pprint :as pprint] - [clojure.set :as set] - [clojure.spec.alpha :as s] - [clojure.walk] - [spec-dict.main :refer [dict]])) - -(defmacro todo - ([] `(throw (ex-info "todo" {}))) - ([fmt & xs] - `(throw (ex-info (format (str "todo: " ~fmt) ~@xs) - {})))) - -(def primitives - '#{let let-syntax letrec lambda syntax-rules if define - define-syntax begin}) - -(def builtins - '#{+ * / - car cdr write display newline cons list}) - -(s/def ::binding - #(match % - [:lexical sym uniq] (and (symbol? sym) (symbol? uniq)) - [:global sym] (symbol? sym))) - -(s/def ::pattern - (s/or :wildcard #{'_} - :var (s/and symbol? (complement #{'... '_})) - :lit ::literal - :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 ::literal (some-fn string? boolean? number? char?)) - -(defn literal? [x] - (s/valid? ::literal x)) - -(s/def ::datum any?) - -(declare variable?) - -(s/def ::template - (s/or :var ::variable - :lit ::literal - :list (s/and (s/* ::template-element) sequential?))) - -(s/def ::template-element - (s/& (s/cat :template ::template :ellipsis (s/? #{'...})) - (s/conformer - (fn [{:keys [ellipsis template]}] - (if ellipsis - [:ellipsis template] - template))))) - -(s/def ::rule - (s/and sequential? - (s/cat :pattern ::pattern - :template ::template))) - -;; cf. `::prim-syntax-rules` -(s/def ::transformer - (dict {:rules (s/coll-of ::rule :kind sequential?)} - ^:opt {:keywords (s/coll-of symbol?)})) - -(s/def ::denotation - #(match % - [:var] true - [:primitive p] (primitives p) - ;; 나쁜 - [:macro trans] (contains? trans :rules) - [:syntax datum] true)) - -(s/def ::environment - (s/map-of ::binding ::denotation)) - -(s/def ::scope symbol?) - -(s/def ::scope-set (s/coll-of ::scope :kind set?)) - -;; this is an inefficient representation. since we often want to -;; compute the submap of entries with a symbol 'x' but any scope, it -;; would be best to 'curry' the table, as Symbol → Scopes → -;; Binding. however, this is a bit more error-prone and cumbersome for -;; a prototype. -(s/def ::symtable - (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?)) - ::binding)) - -(s/def ::formals - (s/coll-of symbol? :kind sequential?)) - -(s/def ::body - (s/+ any?)) - -(declare destructure-variable) - -(defprotocol IVariable - (variable-symbol [this]) - (variable-scopes [this])) - -(deftype Variable [symbol scopes] - Object - (equals [x y] - (if-some [[y-symbol y-scopes] (destructure-variable y)] - (and (.equals symbol y-symbol) - (.equals scopes y-scopes)) - false)) - IVariable - (variable-symbol [this] symbol) - (variable-scopes [this] scopes)) - -(def ^:dynamic *print-variable-scopes* true) - -;; does not respect `*print-dup*` lol -(defmethod print-method Variable [this writer] - (binding [*out* writer] - (if *print-variable-scopes* - (pr [(variable-symbol this) (variable-scopes this)]) - (pr (variable-symbol this))))) - -(defmethod clojure.pprint/simple-dispatch old.Variable [x] - (clojure.pprint/simple-dispatch - (if *print-variable-scopes* - [(variable-symbol x) (variable-scopes x)] - (variable-symbol x)))) - -(s/def ::variable - (s/conformer - (fn [x] - (match x - (_ :guard symbol?) (->Variable x nil) - (_ :guard #(instance? Variable %)) - (if (symbol? (variable-symbol x)) - (let [r (s/conform ::scope-set (variable-scopes x))] - (if (s/invalid? r) - ::s/invalid - (->Variable (variable-symbol x) (variable-scopes x)))) - ::s/invalid) - [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)] - (if (and (symbol? sym) (not (s/invalid? r))) - (->Variable sym r) - ::s/invalid)) - :else ::s/invalid)))) - -(defn variable? [x] - (s/valid? ::variable x)) - -(defn normalise-variale [v] - (let [r (s/conform ::variable v)] - (when-not (s/invalid? r) - r))) - -(defn destructure-variable [v] - (let [r (s/conform ::variable v)] - (when-not (s/invalid? r) - [(variable-symbol r) (variable-scopes r)]))) - -#_ -(defn variable-scopes [v] - (when-some [[_ scopes] (destructure-variable v)] - scopes)) - -#_ -(defn variable-symbol [v] - (when-some [[s _] (destructure-variable v)] - s)) - -(defn offer-scopes - "variable v는 안 resolve되면 v와 scopes는 붙음." - [v scopes] - (let [[sym existing-scopes] (destructure-variable v)] - (->Variable sym (or existing-scopes scopes)))) - -(s/def ::prim-lambda - (s/cat :keyword ::variable - :formals ::formals - :body ::body)) - -(s/def ::prim-let - (s/cat :keyword ::variable - :bindings (s/coll-of #(and (sequential? %) - (= 2 (count %)) - (symbol? (first %))) - :kind sequential?) - :body ::body)) - -(s/def ::prim-let-syntax ::prim-let) - -;; cf. `::transformer` -(s/def ::prim-syntax-rules - (s/and seq? (s/cat :keyword ::variable - :keywords (s/coll-of symbol?) - :rules (s/* ::rule)))) - -(s/def ::prim-if - (s/and seq? (s/cat :keyword ::variable - :condition ::datum - :consequent ::datum - :alternative (s/? ::datum)))) - -(s/def ::prim-begin - (s/and seq? (s/cat :keyword ::variable - :body (s/+ ::datum)))) - - - -(defn symtable-for-env [env] - (into (hash-map) - (for [[[_ x] _] env] - [[x #{}] [:global x]]))) - -(defmacro meta-syntax-rules [kws & body] - `(s/conform ::prim-syntax-rules - (list 'syntax-rules '~kws - ~@(map (fn [x] `(quote ~x)) body)))) - -(defn define-global [env-ref symtable-ref sym denot] - (swap! env-ref #(assoc % [:global sym] denot)) - (swap! symtable-ref #(assoc % [sym #{}] [:global sym]))) - -(declare expand) - -(defn define-macro [env-ref symtable-ref sym trans] - (let [trans (->> (expand trans @env-ref symtable-ref #{}) - (s/conform ::prim-syntax-rules))] - (assert (not (s/invalid? trans))) - (define-global - env-ref - symtable-ref - sym - [:macro trans]))) - -(defn scheme-base [] - (let [env-ref (atom {}) - symtable-ref (atom {})] - (define-global env-ref symtable-ref - 'λ [:primitive 'lambda]) - (doseq [p primitives] - (define-global env-ref symtable-ref - p [:primitive p])) - (doseq [b builtins] - (define-global env-ref symtable-ref - b [:var])) - (define-macro env-ref symtable-ref - 'and '(syntax-rules () - ((_) false) - ((_ a) a) - ((_ a b ...) - (if a (and b ...) a)))) - (define-macro env-ref symtable-ref - 'when '(syntax-rules () - ((_ test body) - (if test body)) - ((_ test body ...) - (if test (begin body))))) - {:env @env-ref - :symtable @symtable-ref}) - #_(merge - {[:global 'λ] [:primitive 'lambda] - [:global 'and] [:macro - (meta-syntax-rules () - ((_) false) - ((_ a) a) - ((_ a b ...) - (if a (and b ...) a)))] - [:global 'when] [:macro - (meta-syntax-rules () - ((_ test body) - (if test body)) - ((_ test body ...) - (if test (begin body))))]} - (into {} (for [p primitives] - [[:global p] [:primitive p]])) - (into {} (for [b builtins] - [[:global b] [:var]])))) - -(defn nearest [[sym scopes] ss] - (when-some [xs (->> ss - (filter #(set/subset? % scopes)) - (group-by count) - seq)] - (second (apply max-key first xs)))) - -(defn- symtable-scopes - "Gather the set of scope-sets associated with a given symbol." - [symtable sym] - (into #{} (for [[[x scopes] _] symtable - :when (= sym x)] - scopes))) - -(defn lookup [variable env symtable] - (let [[sym scopes] (or (destructure-variable variable) - (throw (ex-info "not a var" {:var variable}))) - ss (symtable-scopes symtable sym) - xs (nearest [sym scopes] ss) - r (compare (count xs) 1)] - (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym})) - (zero? r) - (or (get env (or (get symtable [sym (first xs)]) - (throw (ex-info "unreachable" {})))) - (throw (ex-info "unreachable" {}))) - (pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))) - -(comment - (let [{:keys [symtable env]} (scheme-base) - st (atom symtable)] - {:e (expand '(lambda (x y) x) env st #{}) - :st @st})) - -(defmulti expand-primitive - (fn [_datum prim-name _env _symtable-ref _scopes] - prim-name)) - -(defn new-scope - ([] (gensym "scope__")) - ([prefix] (gensym (str "scope__" prefix)))) - -(defn bind-lexical [[sym scopes] denot symtable-ref] - (let [bind [:lexical sym (gensym)]] - (swap! symtable-ref #(assoc % [sym scopes] bind)) - {bind denot})) - -(defn make-symtable [[sym scopes] bind] - {[sym scopes] bind}) - - - -(defn- report-conflict [x y] - (throw (ex-info "너무 정의합니다" - {:x x :y y}))) - -(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 report-conflict 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 #(some-> (unify* ellipsis %) - (update-vals list))) - (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)) - -(defn unification->env [unification symtable-ref scopes] - (into {} - (doall (for [[k v] unification] - (bind-lexical [k scopes] [:syntax v] - symtable-ref))))) - -(defn unify-trans - "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은 - 없으면 nil을 결과할 것입나다. - - 걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은 - trans의 rule이고, unification이 `unify`의 결과입니다." - [trans datum] - (some (fn [{:keys [pattern template] - :as rule}] - (when-some [unif (unify* pattern datum)] - [rule unif])) - (:rules trans))) - -(defn transcribe [template env symtable scopes] - (match template - [:var x] (let [x* (offer-scopes x scopes)] - (match (lookup x* env symtable) - [:syntax [:ellipsis fuckoffmanjustshadowit]] (todo "점점점") - [:syntax syn] syn - :else x*)) - [:ellipsis _] (todo "점점점") - [:lit x] x - [:list xs] - (do (tap> xs) - (map #(transcribe % env symtable scopes) xs)))) - -(defn resolve-template [template scopes] - (clojure.walk/postwalk - #(if (variable? %) - (offer-scopes % scopes) - %) - template)) - - -;;; expand - -(declare expand) - -(defmethod expand-primitive 'lambda - [datum _ env symtable-ref scopes] - (let [{:keys [formals body]} (s/conform ::prim-lambda datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [x formals] - (bind-lexical [x scopes*] - [:var] symtable-ref)))] - (concat (list 'lambda - (for [x formals] - (offer-scopes x scopes*))) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'let - [datum _ env symtable-ref scopes] - (let [{:keys [bindings body]} (s/conform ::prim-let datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [[x _] bindings] - (bind-lexical [x scopes*] - [:var] symtable-ref)))] - (concat (list 'let - (for [[k v] bindings] - (list (offer-scopes k scopes*) v))) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'let-syntax - [datum _ env symtable-ref scopes] - (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum) - scopes* (conj scopes (new-scope)) - env* (apply merge env - (for [[x rhs] bindings] - (let [trans (->> (expand rhs env symtable-ref scopes) - (s/conform ::prim-syntax-rules))] - (assert (not (s/invalid? trans))) - (bind-lexical - [x scopes*] - [:macro trans] - symtable-ref))))] - (concat (list 'let-syntax bindings) - (for [e body] - (expand e env* symtable-ref scopes*))))) - -(defmethod expand-primitive 'syntax-rules - [datum _ env symtable-ref scopes] - (assert (s/valid? ::prim-syntax-rules datum)) - (let [scopes* (conj scopes (new-scope)) - keywords (nth datum 1) - rules (nthrest datum 2)] - (concat (list 'syntax-rules - keywords) - (for [[pattern template] rules] - (list pattern (resolve-template template scopes*)))))) - -(defmethod expand-primitive 'if - [datum _ env symtable-ref scopes] - (let [{:keys [condition consequent alternative]} - (s/conform ::prim-if datum) - ex #(expand % env symtable-ref scopes)] - (concat (list 'if (ex condition) - (ex consequent)) - (some-> alternative ex)))) - -(defmethod expand-primitive 'begin - [datum _ env symtable-ref scopes] - (let [{:keys [body]} (s/conform ::prim-begin datum)] - (cons 'begin (map #(expand % env symtable-ref scopes) body)))) - -(comment - (let [env (:env scheme-base-env) - [_ trans] (get env [:global 'and]) - datum '(and 12 34) - symtable-ref (atom (symtable-for-env env)) - scopes #{1}] - (expand-macro - trans datum - env symtable-ref scopes))) - -(defn expand-macro [trans datum env symtable-ref scopes] - (let [[rule unif] - (-> (unify-trans trans datum) - (or (throw - (ex-info - "데이텀을 맞은 패턴은 찾을 수 없었습니다" - {:trans trans :datum datum})))) - scopes* (conj scopes (new-scope)) - env* (merge env (unification->env unif symtable-ref scopes*))] - (expand (transcribe (:template rule) env* @symtable-ref scopes*) - env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 된가? - symtable-ref - scopes))) - -(defn expand - ([datum] - (let [{:keys [env symtable]} (scheme-base)] - (expand - datum env (atom symtable) #{}))) - ([datum env symtable-ref scopes] - (match datum - ;; literals - (x :guard literal?) x - ;; variables (both resolved and unresolved) - (x :guard variable?) - (let [x* (offer-scopes x scopes)] - (lookup x* env @symtable-ref) ; throw if unbound - x*) - - ;; lists - ([f & xs] :seq) - (or (when-let [v (and (variable? f) - (offer-scopes f scopes))] - (match (lookup v env @symtable-ref) - [:primitive prim] (expand-primitive - datum prim env symtable-ref scopes) - [:macro trans] (expand-macro trans datum env symtable-ref scopes) - [:var] nil)) - (cons (expand f env symtable-ref scopes) - (map #(expand % env symtable-ref scopes) xs)))))) - - - -(defn regensym - "Renumber the gensyms created by `new-scope` found in datum, - starting from zero." - [datum] - (let [c (atom {})] - (clojure.walk/postwalk - (fn [x] - (if (instance? Variable x) - (let [[sym scopes] (destructure-variable x) - syms (swap! - c - #(let [r (set/difference scopes - (set (keys %)))] - (into % - (map-indexed - (fn [n a] - [a (symbol (str "s" (+ (count %) n)))]) - r))))] - #_(->Variable sym (set (map #(get syms %) scopes))) - [sym (set (map #(get syms %) scopes))]) - x)) - datum))) - -(defn unscope - "Remove all scopes from the variables found in datum." - [datum] - (clojure.walk/postwalk - (fn [x] - (if (instance? Variable x) - (variable-symbol x) - x)) - datum)) - -(defn us-expand [datum] - (unscope (expand datum))) - -(defn rg-expand [datum] - (regensym (expand datum))) diff --git a/src/unhygienic.clj b/src/unhygienic.clj deleted file mode 100644 index fcaa6a0..0000000 --- a/src/unhygienic.clj +++ /dev/null @@ -1,106 +0,0 @@ -(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/core_test.clj similarity index 95% rename from test/expand_test.clj rename to test/expand/core_test.clj index f548a81..d7d9c63 100644 --- a/test/expand_test.clj +++ b/test/expand/core_test.clj @@ -1,8 +1,9 @@ -(ns expand-test - (:require [expand :as sut] - [clojure.test :as t] - [clojure.spec.alpha :as s] - [scm])) +(ns expand.core-test + (:require + [clojure.spec.alpha :as s] + [clojure.test :as t] + [expand.core :as sut] + [expand.scm :as scm])) (t/deftest nearest-test (t/is (= '#{#{a b}} diff --git a/test/scm_test.clj b/test/expand/scm_test.clj similarity index 90% rename from test/scm_test.clj rename to test/expand/scm_test.clj index f8eb6d5..52e1544 100644 --- a/test/scm_test.clj +++ b/test/expand/scm_test.clj @@ -1,7 +1,7 @@ -(ns scm-test - (:require [scm :as sut] - [clojure.test :as t]) - (:import scm.ISyntax scm.Syntax)) +(ns expand.scm-test + (:require [clojure.test :as t] + [expand.scm :as sut]) + (:import (expand.scm ISyntax Syntax))) (t/deftest read-test (t/testing "boolean" @@ -63,8 +63,8 @@ (t/is (= 123 (sut/syntax-e #scm/stx [123 #{}])))) (t/deftest unresolved?-test - (t/is (sut/unresolved? (scm/->Syntax 123 nil))) + (t/is (sut/unresolved? (sut/->Syntax 123 nil))) (t/is (sut/unresolved? #scm/stx 123))) (t/deftest resolved?-test - (t/is (sut/resolved? (scm/->Syntax 123 '#{a})))) + (t/is (sut/resolved? (sut/->Syntax 123 '#{a})))) diff --git a/test/expand/syntax_rules_test.clj b/test/expand/syntax_rules_test.clj index dd67fee..635b033 100644 --- a/test/expand/syntax_rules_test.clj +++ b/test/expand/syntax_rules_test.clj @@ -2,7 +2,8 @@ (:require [expand.syntax-rules :as sut] [clojure.core.match :refer [match]] [clojure.test :as t] - [clojure.walk :as walk])) + [clojure.walk :as walk] + [expand.scm :as scm])) (defmacro broken-is [form] `(t/is (not ~form) diff --git a/test/old_test.clj b/test/old_test.clj deleted file mode 100644 index 1b115cb..0000000 --- a/test/old_test.clj +++ /dev/null @@ -1,152 +0,0 @@ -(ns old-test - (:require - [clojure.core.match :refer [match]] - [clojure.spec.alpha :as s] - [clojure.test :as t] - [old :as sut])) - -(t/deftest scheme-base-test - (t/is (s/valid? ::sut/environment (:env sut/scheme-base))) - (t/is (s/valid? ::sut/symtable (:symtable sut/scheme-base)))) - -(t/deftest nearest-test - #_(t/is (= [:primitive 'lambda] - (sut/lookup ['lambda #{}] - sut/scheme-base-env - (sut/symtable-for-env sut/scheme-base-env)))) - (t/is (= [#{0 1}] - (sut/nearest ['x #{0 1 2}] - [#{0} #{0 1} #{0 3}])))) - -(t/deftest pattern-spec - (t/testing "var" - (let [pattern-var? #(match (s/conform ::pattern %) - [:var _] true - _ false)] - (t/is (pattern-var? 'abc)) - (t/is (not (pattern-var? '_))) - (t/is (not (pattern-var? '...))))) - (t/testing "list" - (t/are [l e t x] (= [l e t] - ((juxt :leading :ellipsis :trailing) - (s/conform ::pattern x))) - nil nil nil '() - '(a) nil nil '(a) - '(a b) nil nil '(a b) - '(a) 'b nil '(a b ...) - '(a) 'b '(c) '(a b ... c) - '(a) 'b '(c d) '(a b ... c d)) - (t/are [p] (s/invalid? ::pattern p) - '... '(...) '(... a b c) - '(a ... b ...))) - (t/testing "simple data" - (t/is (= 'a (s/conform ::patern 'a))))) - -(t/deftest expand-test - (t/testing "unbound symbol" - (t/is (thrown? Exception (sut/expand 'x)))) - (t/testing "lambda" - (t/is (= '(lambda (x) x) - (sut/us-expand '(λ (x) x))))) - (t/testing "let-syntax" - (t/is (= '(let-syntax ((m (syntax-rules - () - ((m) 123)))) - 456) - (sut/expand - '(let-syntax ((m (syntax-rules - () - ((m) 123)))) - 456))))) - (t/testing "let" - (t/is (= '(let ((x 123) - (y 456)) - (+ x y)) - (sut/us-expand - '(let ((x 123) - (y 456)) - (+ x y)))))) - (t/testing "application" - (t/is (= '(lambda (f x) (f x)) - (sut/us-expand '(lambda (f x) (f x)))))) - (t/testing "macros" - (t/testing "when" - (t/is (= '(let ((x 123)) (if x 456)) - (sut/us-expand '(let ((x 123)) - (when x 456))))) - (t/is (= '(let (([body #{s0}] 123)) - (if [body #{s0}] - 456)) - (sut/rg-expand '(let ((body 123)) - (when body 456)))) - "`when` does not clobber caller's scope") - (t/is (= '(let (([x #{s0}] 123)) - (let-syntax ((m (syntax-rules () ((m) x)))) - (lambda ([x #{s1 s2 s0}]) - [x #{s0 s3}]))) - (sut/rg-expand '(let ((x 123)) - (let-syntax ((m (syntax-rules - () - ((m) x)))) - (λ (x) - (m)))))) - "`when` does not capture caller's scope") - (t/is (= '(if 123 (begin (display "hello") - (newline))) - (sut/us-expand '(when 123 - (display "hello") - (newline)))) - "`when` captures multiple")))) - -(t/deftest prim-lambda-spec - (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x))) - (t/is (s/valid? ::sut/prim-lambda '(lambda (x) (display x) (newline))))) - -(t/deftest prim-let-spec - (t/is (s/valid? ::sut/prim-let '(let ((x 123) - (y 456)) - (+ x y))))) - -(t/deftest prim-let-syntax-spec - (t/is (s/valid? ::sut/prim-let-syntax - '(let-syntax ((m (syntax-rules () - ((m) 123)))) - (m))))) - -(t/deftest template-spec - (t/is (s/valid? ::sut/template '(x ... y))) - (t/is (s/valid? ::sut/template 123)) - (t/is (= '[:list [[:var x] - [:ellipsis [:var y]] - [:ellipsis [:var z]] - [:var a] - [:var b] - [:var c]]] - (s/conform ::sut/template '(x y ... z ... a b c))))) - -(t/deftest pattern-spec - (t/is (s/valid? ::sut/pattern '(m)))) - -(t/deftest rule-spec - (t/is (s/valid? ::sut/rule '((m) 123)))) - -(t/deftest prim-syntax-rules-spec - (t/is (s/valid? ::sut/prim-syntax-rules - '(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)))) diff --git a/test/unhygienic_test.clj b/test/unhygienic_test.clj deleted file mode 100644 index dc62699..0000000 --- a/test/unhygienic_test.clj +++ /dev/null @@ -1,30 +0,0 @@ -(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 ...) ...)))