diff --git a/src/expand.clj b/src/expand.clj index 69039ab..b4c3cc6 100644 --- a/src/expand.clj +++ b/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)) diff --git a/test/expand_test.clj b/test/expand_test.clj index e53bfc8..6ad4988 100644 --- a/test/expand_test.clj +++ b/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)))