var record

src/expand.clj

@@ -2,7 +2,8 @@
   (:require [clojure.spec.alpha :as s]
             [clojure.core.match :refer [match]]
             [spec-dict.main :refer [dict]]
-            [clojure.set :as set]))
+            [clojure.set :as set]
+            [clojure.pprint :as pprint]))
 
 (defmacro todo
   ([] `(throw (ex-info "todo" {})))
@@ -98,40 +99,67 @@
 (s/def ::body
   (s/+ any?))
 
+(defrecord Variable [symbol 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 [(:symbol this) (:scopes this)])
+      (pr (:symbol this)))))
+
+(defmethod clojure.pprint/simple-dispatch expand.Variable [x]
+  (clojure.pprint/simple-dispatch
+   (if *print-variable-scopes*
+     [(:symbol x) (:scopes x)]
+     (:symbol x))))
+
 (s/def ::variable
   (s/conformer
-   #(match %
-      (x :guard symbol?) [x nil]
-      [x scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
-                   (if (or (not (symbol? x)) (s/invalid? r))
-                     ::s/invalid
-                     [x scopes]))
-      :else ::s/invalid)))
+   (fn [x]
+     (match x
+       (_ :guard symbol?) (->Variable x nil)
+       (_ :guard #(instance? Variable %))
+       (if (symbol? (:symbol x))
+         (let [r (s/conform ::scope-set (:scopes x))]
+           (if (s/invalid? r)
+             ::s/invalid
+             (->Variable (:symbol x) (: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)))
+       :else ::s/invalid))))
 
 (defn variable? [x]
   (s/valid? ::variable x))
 
-(defn variable-symbol [v]
-  (if (symbol? v)
-    v
-    (first v)))
-
 (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)
+      [(:symbol r) (:scopes r)])))
+
 (defn variable-scopes [v]
-  (match v
-    [_ scopes] scopes
-    :else nil))
+  (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]
-  (if-some [ss (variable-scopes v)]
-    [(variable-symbol v) ss]
-    [(variable-symbol v) scopes]))
+  (let [[sym existing-scopes] (destructure-variable v)]
+    (->Variable sym (or existing-scopes scopes))))
 
 (s/def ::prim-lambda
   (s/cat :keyword ::variable
@@ -206,7 +234,7 @@
 
 (defn lookup [variable env symtable]
   (tap> [variable env symtable])
-  (let [[sym scopes] (or (normalise-variale variable)
+  (let [[sym scopes] (or (destructure-variable variable)
                          (throw (ex-info "not a var" {:var variable})))
         ss (symtable-scopes symtable sym)]
     (let [xs (nearest [sym scopes] ss)
@@ -357,8 +385,7 @@
                                     [:var] symtable-ref)))]
     (concat (list 'let
                   (for [[k v] bindings]
-                    [(offer-scopes k scopes*)
-                     v]))
+                    (list (emit-variable (offer-scopes k scopes*)) v)))
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
@@ -433,9 +460,10 @@
      ;; lists
      ([f & xs] :seq)
      (if (variable? f)
-       (match (lookup (offer-scopes f scopes) env @symtable-ref)
-         [:primitive prim] (expand-primitive
-                            datum prim env symtable-ref scopes)
-         [:macro trans] (expand-macro trans datum env symtable-ref scopes))
+       (do (tap> f)
+           (match (lookup (offer-scopes f scopes) env @symtable-ref)
+             [:primitive prim] (expand-primitive
+                                datum prim env symtable-ref scopes)
+             [:macro trans] (expand-macro trans datum env symtable-ref scopes)))
        (cons (expand f env symtable-ref scopes)
              (map #(expand % env symtable-ref scopes) xs))))))