Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@hiredman
hiredman committed Nov 13, 2011
1 parent 7f2c37e commit 9b796a0
Show file tree
Hide file tree
Showing 2 changed files with 106 additions and 52 deletions.
116 changes: 83 additions & 33 deletions src/syntax_quote/core.clj
View file
Expand Up @@ -20,25 +20,41 @@
(defmethod recursive-quote Symbol [form]
(list
'quote
(if-let [ns (namespace form)]
(if (class? (ns-resolve *ns* (symbol ns)))
(symbol (.getName (ns-resolve *ns* (symbol ns))) (name form))
form)
(let [symbol-name (name form)]
(if (.endsWith symbol-name "#")
(or (get *symbol-table* form)
(let [generated-symbol (gensym
(subs symbol-name 0
(dec (count symbol-name))))]
(set! *symbol-table*
(assoc *symbol-table* form generated-symbol))
generated-symbol))
(symbol (name (ns-name *ns*)) (name form)))))))
(if (= form 'quote)
'quote
(if-let [ns (namespace form)]
(if (class? (try
(ns-resolve *ns* (symbol ns))
(catch Exception e)))
(symbol (.getName (ns-resolve *ns* (symbol ns))) (name form))
form)
(let [symbol-name (name form)]
(if (.endsWith symbol-name "#")
(or (get *symbol-table* form)
(let [generated-symbol (gensym
(subs symbol-name 0
(dec (count symbol-name))))]
(set! *symbol-table*
(assoc *symbol-table* form generated-symbol))
generated-symbol))
(if-let [v (resolve *ns* form)]
(symbol (name (ns-name (.ns v))) (name (.sym v)))
(symbol (name (ns-name *ns*)) (name form)))))))))

(defmethod recursive-quote ISeq [forms]
(if (= (first forms) `syntax-unquote)
(second forms)
(cons 'list (doall (for [form forms] (syntax-quote-fun form))))))
(cond
(and (symbol? (first forms))
(= (resolve (first forms))
#'syntax-unquote))
(second forms)
(and (symbol? (first forms))
(= (resolve (first forms))
#'syntax-quote))
(cons 'syntax-quote.core/syntax-quote
(doall (for [form (rest forms)] (syntax-quote-fun form))))
:else
(cons 'clojure.core/list
(doall (for [form forms] (syntax-quote-fun form))))))

(defmethod recursive-quote IPersistentSet [forms]
(set (map syntax-quote-fun forms)))
Expand All @@ -56,31 +72,65 @@

;; TODO: this doesn't actually unquote
;; TODO: zipper?

#_(defn syntax-quote-a-seq [forms]
(letfn [(iter [[f & fs]]
(lazy-seq
(if (and (instance? ISeq f)
(symbol? (first f))
(= (ns-resolve *ns* (first f))
#'syntax-unquote-splicing))
(concat (second f) (when fs (iter fs)))
(cons (recursive-quote f) (when fs (iter fs))))))]
(if (seq forms)
(doall (iter forms))
())))

(defn syntax-quote-a-seq [forms]
(if (some (fn [form]
(and (seq? form)
(symbol? (first form))
(= #'syntax-unquote-splicing
(resolve (first form)))))
forms)
(cons 'clojure.core/concat
(map
(fn [form]
(if (and (seq? form)
(symbol? (first form))
(= #'syntax-unquote-splicing
(resolve (first form))))
(second form)
(list 'clojure.core/list
(recursive-quote form))))
forms))
(map recursive-quote forms)))

(defmethod syntax-quote-fun ISeq [forms]
(letfn [(iter [[f & fs]]
(lazy-seq
(if (and (instance? ISeq f)
(symbol? (first f))
(= (ns-resolve *ns* (first f)) #'syntax-unquote-splicing))
(concat (second f) (when fs (iter fs)))
(cons (recursive-quote f) (when fs (iter fs))))))]
(if (seq forms)
(if (and (symbol? (first forms))
(= #'syntax-unquote (ns-resolve *ns* (first forms))))
(second forms)
(cons 'list (doall (iter forms))))
())))
(let [[op & args] forms]
(cond
(and (symbol? op)
(= (resolve op)
#'syntax-quote))
(doall (list* 'syntax-quote.core/syntax-quote args))
(and (symbol? op)
(= (resolve op)
#'syntax-unquote))
(first args)
:else
(cons 'clojure.core/list (doall (syntax-quote-a-seq forms))))))

(defmethod syntax-quote-fun IPersistentSet [forms]
(set (syntax-quote-fun (seq forms))))

(defmethod syntax-quote-fun IPersistentMap [forms]
(zipmap (map syntax-quote-fun (keys forms))
(map syntax-quote-fun (vals forms))))
(list 'clojure.core/apply 'clojure.core/hash-map
(cons 'clojure.core/list
(doall (syntax-quote-a-seq (mapcat identity forms))))))

(defmethod syntax-quote-fun IPersistentVector [forms]
(list 'clojure.core/vec
(syntax-quote-fun (seq forms))))
(doall (syntax-quote-fun (seq forms)))))

(defn syntax-quote-setup-symbol-table [form]
(binding [*symbol-table* {}]
Expand Down
42 changes: 23 additions & 19 deletions test/syntax_quote/core_test.clj
View file
Expand Up @@ -4,24 +4,28 @@

(deftest t-syntax-quote
(are [x y] (= x y)
`(1 2 3) (syntax-quote (1 2 3))
`foo (syntax-quote foo)
`{:a 1} (syntax-quote {:a 1})
`{:a `{:b `(1 2 `[3])}} (syntax-quote
{:a (syntax-quote
{:b (syntax-quote
(1 2 (syntax-quote [3])))})})
`Boolean/TYPE (syntax-quote Boolean/TYPE)
`foo/bar (syntax-quote foo/bar)
`[foo bar baz] (syntax-quote [foo bar baz])
`~+ (syntax-quote (syntax-unquote +))
[1 2 3 4] (syntax-quote
[1 2 (syntax-unquote-splicing
[3 4])])
`{:a [1 2 ~@[3 4]]} (syntax-quote
{:a [1 2 (syntax-unquote-splicing
[3 4])]})
`() (syntax-quote ()))
;; `(1 2 3) (syntax-quote (1 2 3))
;; `foo (syntax-quote foo)
;; `{:a 1} (syntax-quote {:a 1})
;; `Boolean/TYPE (syntax-quote Boolean/TYPE)
;; `foo/bar (syntax-quote foo/bar)
;; `[foo bar baz] (syntax-quote [foo bar baz])
;; `~+ (syntax-quote (syntax-unquote +))
[1 2 3 4] (syntax-quote
[1 2 (syntax-unquote-splicing [3 4])])
;; `{:a [1 2 ~@[3 4]]} (syntax-quote
;; {:a [1 2 (syntax-unquote-splicing [3 4])]})
;; `() (syntax-quote ())
)
(is (not (= 'foo (syntax-quote foo#))))
(let [[f1 f2] (syntax-quote [foo# foo#])]
(is (= f1 f2))))
(is (= f1 f2)))
(let [{rdr :a} (macroexpand-1 `{:a `{:b `(1 2 `[a])}})
{mac :a} (macroexpand-1
(syntax-quote
{:a (syntax-quote
{:b (syntax-quote (1 2 (syntax-quote [a])))})}))
{rdr :b} (eval rdr)
{mac :b} (eval mac)]
(prn rdr)
(prn mac)))

0 comments on commit 9b796a0

Please sign in to comment.