src/expand.clj

@@ -3,7 +3,9 @@
             [clojure.core.match :refer [match]]
             [spec-dict.main :refer [dict]]
             [clojure.set :as set]
-            [clojure.pprint :as pprint]))
+            [clojure.pprint :as pprint]
+            [clojure.string :as str]
+            [clojure.walk]))
 
 (defmacro todo
   ([] `(throw (ex-info "todo" {})))
@@ -99,7 +101,25 @@
 (s/def ::body
   (s/+ any?))
 
-(defrecord Variable [symbol scopes])
+(declare destructure-variable)
+
+(defprotocol IVariable
+  (variable-symbol [this])
+  (variable-scopes [this]))
+
+(deftype Variable [symbol scopes]
+  Object
+  (equals [x y]
+    (tap> y)
+    (if-some [[y-symbol y-scopes] (destructure-variable y)]
+      (do (tap> [symbol y-symbol])
+          (tap> [scopes y-scopes])
+          (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)
 
@@ -107,14 +127,14 @@
 (defmethod print-method Variable [this writer]
   (binding [*out* writer]
     (if *print-variable-scopes*
-      (pr [(:symbol this) (:scopes this)])
-      (pr (:symbol this)))))
+      (pr [(variable-symbol this) (variable-scopes this)])
+      (pr (variable-symbol this)))))
 
 (defmethod clojure.pprint/simple-dispatch expand.Variable [x]
   (clojure.pprint/simple-dispatch
    (if *print-variable-scopes*
-     [(:symbol x) (:scopes x)]
-     (:symbol x))))
+     [(variable-symbol x) (variable-scopes x)]
+     (variable-symbol x))))
 
 (s/def ::variable
   (s/conformer
@@ -122,16 +142,16 @@
      (match x
        (_ :guard symbol?) (->Variable x nil)
        (_ :guard #(instance? Variable %))
-       (if (symbol? (:symbol x))
-         (let [r (s/conform ::scope-set (:scopes x))]
+       (if (symbol? (variable-symbol x))
+         (let [r (s/conform ::scope-set (variable-scopes x))]
            (if (s/invalid? r)
              ::s/invalid
-             (->Variable (:symbol x) (:scopes x))))
+             (->Variable (variable-symbol x) (variable-scopes x))))
          ::s/invalid)
        [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
-                      (if (or (not (symbol? sym)) (s/invalid? r))
-                        ::s/invalid
-                        (->Variable sym r)))
+                      (if (and (symbol? sym) (not (s/invalid? r)))
+                        (->Variable sym r)
+                        ::s/invalid))
        :else ::s/invalid))))
 
 (defn variable? [x]
@@ -145,12 +165,14 @@
 (defn destructure-variable [v]
   (let [r (s/conform ::variable v)]
     (when-not (s/invalid? r)
-      [(:symbol r) (:scopes 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))
@@ -384,7 +406,7 @@
                                     [:var] symtable-ref)))]
     (concat (list 'let
                   (for [[k v] bindings]
-                    (list (emit-variable (offer-scopes k scopes*)) v)))
+                    (list (offer-scopes k scopes*) v)))
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
@@ -469,25 +491,27 @@
 
 
 
-(defn beautify
+(defn regensym
   "Renumber the gensyms created by `new-scope` found in datum,
   starting from zero."
   [datum]
-  (let [c (atom 0)]
-    (walk/postwalk (fn [x]
-                     (if (and (symbol? x)
-                              (clojure.string/starts-with?
-                               (name x)
-                               "scope__"))
-                       (symbol (str "s" (first (swap-vals! c inc))))
-                       x))
-                   datum)))
+  (let [c (atom {})]
+    (clojure.walk/postwalk
+     (fn [x]
+       (if (and (symbol? x) (str/starts-with? (name x) "scope__"))
+         (let [syms (swap! c #(if (contains? % x)
+                                %
+                                (assoc % x (symbol (str "s" (count %))))))]
+           (get syms x))
+         x))
+     datum)))
 
 (defn unscope
   "Remove all scopes from the variables found in datum."
   [datum]
-  (walk/postwalk (fn [x]
-                   (if (instance? Variable x)
-                     (variable-symbol x)
-                     x))
-                 datum))
+  (clojure.walk/postwalk
+   (fn [x]
+     (if (instance? Variable x)
+       (variable-symbol x)
+       x))
+   datum))

test/expand_test.clj

@@ -46,6 +46,9 @@
 (defn- us-expand [datum]
   (sut/unscope (sut/expand datum)))
 
+(defn- rg-expand [datum]
+  (sut/regensym (sut/expand datum)))
+
 (t/deftest expand-test
   (t/testing "unbound symbol"
     (t/is (thrown? Exception (sut/expand 'x))))
@@ -53,11 +56,11 @@
     (t/is (= '(lambda (x) x)
              (us-expand '(λ (x) x)))))
   #_(t/testing "syntax-rules"
-    (t/is (= '(lambda (x) x)
-             (sut/expand
-              '(syntax-rules
-                ()
-                ((_)))))))
+      (t/is (= '(lambda (x) x)
+               (sut/expand
+                '(syntax-rules
+                  ()
+                  ((_)))))))
   (t/testing "let"
     (t/is (= '(let ((x 123)
                     (y 456))
@@ -68,7 +71,18 @@
                  (+ x y))))))
   (t/testing "application"
     (t/is (= '(lambda (f x) (f x))
-             (us-expand '(lambda (f x) (f x)))))))
+             (us-expand '(lambda (f x) (f x))))))
+  (t/testing "macros"
+    (t/testing "when"
+      (t/is (= '(let ((x 123)) (if x 456))
+               (us-expand '(let ((x 123))
+                             (when x 456)))))
+      (t/is (= '(let (([body #{s0}] 123))
+                  (if [body #{s0}]
+                    456))
+               (rg-expand '(let ((body 123))
+                             (when body 456))))
+            "`when` is hygienic"))))
 
 (t/deftest prim-lambda-spec
   (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))