청소

src/data_readers.clj

@@ -1 +1 @@
-{scm/stx scm/stx-reader}
+{scm/stx expand.scm/stx-reader}

src/expand/common.clj

@@ -1,4 +1,4 @@
-(ns common)
+(ns expand.common)
 
 (defmacro inherit [& syms]
   (let [f (if (<= 8 (count syms))

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

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 데이텀 한 개를 받는다.

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

src/old.clj

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

src/unhygienic.clj

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

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

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

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)

test/old_test.clj

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

test/unhygienic_test.clj

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