rlm@10: ;; Macrolet and symbol-macrolet
rlm@10: 
rlm@10: ;; by Konrad Hinsen
rlm@10: ;; last updated January 14, 2010
rlm@10: 
rlm@10: ;; Copyright (c) Konrad Hinsen, 2009-2010. All rights reserved.  The use
rlm@10: ;; and distribution terms for this software are covered by the Eclipse
rlm@10: ;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
rlm@10: ;; which can be found in the file epl-v10.html at the root of this
rlm@10: ;; distribution.  By using this software in any fashion, you are
rlm@10: ;; agreeing to be bound by the terms of this license.  You must not
rlm@10: ;; remove this notice, or any other, from this software.
rlm@10: 
rlm@10: (ns
rlm@10:   ^{:author "Konrad Hinsen"
rlm@10:      :doc "Local macros and symbol macros
rlm@10: 
rlm@10:            Local macros are defined by a macrolet form. They are usable only
rlm@10:            inside its body. Symbol macros can be defined globally
rlm@10:            (defsymbolmacro) or locally (symbol-macrolet). A symbol
rlm@10:            macro defines a form that replaces a symbol during macro
rlm@10:            expansion. Function arguments and symbols bound in let
rlm@10:            forms are not subject to symbol macro expansion.
rlm@10: 
rlm@10:            Local macros are most useful in the definition of the expansion
rlm@10:            of another macro, they may be used anywhere. Global symbol
rlm@10:            macros can be used only inside a with-symbol-macros form."}
rlm@10:   clojure.contrib.macro-utils
rlm@10:   (:use [clojure.contrib.def :only (defvar-)]))
rlm@10: 
rlm@10: ; A set of all special forms. Special forms are not macro-expanded, making
rlm@10: ; it impossible to shadow them by macro definitions. For most special
rlm@10: ; forms, all the arguments are simply macro-expanded, but some forms
rlm@10: ; get special treatment.
rlm@10: (defvar- special-forms
rlm@10:   (into #{} (keys clojure.lang.Compiler/specials)))
rlm@10: ; Value in the Clojure 1.2 branch:
rlm@10: ; #{deftype* new quote & var set! monitor-enter recur . case* clojure.core/import* reify* do fn* throw monitor-exit letfn* finally let* loop* try catch if def}
rlm@10: 
rlm@10: ; The following three vars are constantly redefined using the binding
rlm@10: ; form, imitating dynamic scoping.
rlm@10: ;
rlm@10: ; Local macros.
rlm@10: (defvar- macro-fns {})
rlm@10: ; Local symbol macros.
rlm@10: (defvar- macro-symbols {})
rlm@10: ; Symbols defined inside let forms or function arguments.
rlm@10: (defvar- protected-symbols #{})
rlm@10: 
rlm@10: (defn- reserved?
rlm@10:   [symbol]
rlm@10:   "Return true if symbol is a reserved symbol (starting or ending with a dot)."
rlm@10:   (let [s (str symbol)]
rlm@10:     (or (= "." (subs s 0 1))
rlm@10: 	(= "." (subs s (dec (count s)))))))
rlm@10: 
rlm@10: (defn- expand-symbol
rlm@10:   "Expand symbol macros"
rlm@10:   [symbol]
rlm@10:   (cond (contains? protected-symbols symbol) symbol
rlm@10: 	(reserved? symbol)                   symbol
rlm@10: 	(contains? macro-symbols symbol)     (get macro-symbols symbol)
rlm@10: 	:else (let [v (resolve symbol)
rlm@10: 		    m (meta v)]
rlm@10: 		(if (:symbol-macro m)
rlm@10: 		  (var-get v)
rlm@10: 		  symbol))))
rlm@10: 
rlm@10: (defn- expand-1
rlm@10:   "Perform a single non-recursive macro expansion of form."
rlm@10:   [form]
rlm@10:   (cond
rlm@10:     (seq? form)
rlm@10:       (let [f (first form)]
rlm@10:         (cond (contains? special-forms f) form
rlm@10: 	      (contains? macro-fns f)     (apply (get macro-fns f) (rest form))
rlm@10: 	      (symbol? f)                 (let [exp (expand-symbol f)]
rlm@10: 					    (if (= exp f)
rlm@10: 					      (clojure.core/macroexpand-1 form)
rlm@10: 					      (cons exp (rest form))))
rlm@10: 	      ; handle defmacro macros and Java method special forms
rlm@10: 	      :else (clojure.core/macroexpand-1 form)))
rlm@10:     (symbol? form)
rlm@10:       (expand-symbol form)
rlm@10:      :else
rlm@10:        form))
rlm@10: 
rlm@10: (defn- expand
rlm@10:   "Perform repeated non-recursive macro expansion of form, until it no
rlm@10:    longer changes."
rlm@10:   [form]
rlm@10:   (let [ex (expand-1 form)]
rlm@10:     (if (identical? ex form)
rlm@10:       form
rlm@10:       (recur ex))))
rlm@10: 
rlm@10: (declare expand-all)
rlm@10: 
rlm@10: (defn- expand-args
rlm@10:   "Recursively expand the arguments of form, leaving its first
rlm@10:    n elements unchanged."
rlm@10:   ([form]
rlm@10:    (expand-args form 1))
rlm@10:   ([form n]
rlm@10:    (doall (concat (take n form) (map expand-all (drop n form))))))
rlm@10: 
rlm@10: (defn- expand-bindings
rlm@10:   [bindings exprs]
rlm@10:   (if (empty? bindings)
rlm@10:     (list (doall (map expand-all exprs)))
rlm@10:     (let [[[s b] & bindings] bindings]
rlm@10:       (let [b (expand-all b)]
rlm@10: 	(binding [protected-symbols (conj protected-symbols s)]
rlm@10: 	  (doall (cons [s b] (expand-bindings bindings exprs))))))))
rlm@10: 
rlm@10: (defn- expand-with-bindings
rlm@10:   "Handle let* and loop* forms. The symbols defined in them are protected
rlm@10:    from symbol macro expansion, the definitions and the body expressions
rlm@10:    are expanded recursively."
rlm@10:   [form]
rlm@10:   (let [f        (first form)
rlm@10: 	bindings (partition 2 (second form))
rlm@10: 	exprs    (rest (rest form))
rlm@10: 	expanded (expand-bindings bindings exprs)
rlm@10: 	bindings (vec (apply concat (butlast expanded)))
rlm@10: 	exprs    (last expanded)]
rlm@10:     (cons f (cons bindings exprs))))
rlm@10: 
rlm@10: (defn- expand-fn-body
rlm@10:   [[args & exprs]]
rlm@10:   (binding [protected-symbols (reduce conj protected-symbols
rlm@10: 				     (filter #(not (= % '&)) args))]
rlm@10:     (cons args (doall (map expand-all exprs)))))
rlm@10: 
rlm@10: (defn- expand-fn
rlm@10:   "Handle fn* forms. The arguments are protected from symbol macro
rlm@10:    expansion, the bodies are expanded recursively."
rlm@10:   [form]
rlm@10:   (let [[f & bodies] form
rlm@10: 	name         (when (symbol? (first bodies)) (first bodies))
rlm@10: 	bodies       (if (symbol? (first bodies)) (rest bodies) bodies)
rlm@10: 	bodies       (if (vector? (first bodies)) (list bodies) bodies)
rlm@10: 	bodies       (doall (map expand-fn-body bodies))]
rlm@10:     (if (nil? name)
rlm@10:       (cons f bodies)
rlm@10:       (cons f (cons name bodies)))))
rlm@10: 
rlm@10: (defn- expand-method
rlm@10:   "Handle a method in a deftype* or reify* form."
rlm@10:   [m]
rlm@10:   (rest (expand-fn (cons 'fn* m))))
rlm@10: 
rlm@10: (defn- expand-deftype
rlm@10:   "Handle deftype* forms."
rlm@10:   [[symbol typename classname fields implements interfaces & methods]]
rlm@10:   (assert (= implements :implements))
rlm@10:   (let [expanded-methods (map expand-method methods)]
rlm@10:     (concat
rlm@10:      (list symbol typename classname fields implements interfaces)
rlm@10:      expanded-methods)))
rlm@10: 
rlm@10: (defn- expand-reify
rlm@10:   "Handle reify* forms."
rlm@10:   [[symbol interfaces & methods]]
rlm@10:   (let [expanded-methods (map expand-method methods)]
rlm@10:     (cons symbol (cons interfaces expanded-methods))))
rlm@10: 
rlm@10: ; Handlers for special forms that require special treatment. The default
rlm@10: ; is expand-args.
rlm@10: (defvar- special-form-handlers
rlm@10:   {'quote 	  identity
rlm@10:    'var   	  identity
rlm@10:    'def   	  #(expand-args % 2)
rlm@10:    'new           #(expand-args % 2)
rlm@10:    'let*          expand-with-bindings
rlm@10:    'loop*         expand-with-bindings
rlm@10:    'fn*           expand-fn
rlm@10:    'deftype*      expand-deftype
rlm@10:    'reify*        expand-reify})
rlm@10: 
rlm@10: (defn- expand-list
rlm@10:   "Recursively expand a form that is a list or a cons."
rlm@10:   [form]
rlm@10:   (let [f (first form)]
rlm@10:     (if (symbol? f)
rlm@10:       (if (contains? special-forms f)
rlm@10: 	((get special-form-handlers f expand-args) form)
rlm@10: 	(expand-args form))
rlm@10:       (doall (map expand-all form)))))
rlm@10: 
rlm@10: (defn- expand-all
rlm@10:   "Expand a form recursively."
rlm@10:   [form]
rlm@10:   (let [exp (expand form)]
rlm@10:     (cond (symbol? exp) exp
rlm@10: 	  (seq? exp) (expand-list exp)
rlm@10: 	  (vector? exp) (into [] (map expand-all exp))
rlm@10: 	  (map? exp) (into {} (map expand-all (seq exp)))
rlm@10: 	  :else exp)))
rlm@10: 
rlm@10: (defmacro macrolet
rlm@10:   "Define local macros that are used in the expansion of exprs. The
rlm@10:    syntax is the same as for letfn forms."
rlm@10:   [fn-bindings & exprs]
rlm@10:   (let [names      (map first fn-bindings)
rlm@10: 	name-map   (into {} (map (fn [n] [(list 'quote n) n]) names))
rlm@10: 	macro-map  (eval `(letfn ~fn-bindings ~name-map))]
rlm@10:     (binding [macro-fns     (merge macro-fns macro-map)
rlm@10: 	      macro-symbols (apply dissoc macro-symbols names)]
rlm@10:       `(do ~@(doall (map expand-all exprs))))))
rlm@10: 
rlm@10: (defmacro symbol-macrolet
rlm@10:   "Define local symbol macros that are used in the expansion of exprs.
rlm@10:    The syntax is the same as for let forms."
rlm@10:   [symbol-bindings & exprs]
rlm@10:   (let [symbol-map (into {} (map vec (partition 2 symbol-bindings)))
rlm@10: 	names      (keys symbol-map)]
rlm@10:     (binding [macro-fns     (apply dissoc macro-fns names)
rlm@10: 	      macro-symbols (merge macro-symbols symbol-map)]
rlm@10:       `(do ~@(doall (map expand-all exprs))))))
rlm@10: 
rlm@10: (defmacro defsymbolmacro
rlm@10:   "Define a symbol macro. Because symbol macros are not part of
rlm@10:    Clojure's built-in macro expansion system, they can be used only
rlm@10:    inside a with-symbol-macros form."
rlm@10:   [symbol expansion]
rlm@10:   (let [meta-map (if (meta symbol) (meta symbol) {})
rlm@10: 	meta-map (assoc meta-map :symbol-macro true)]
rlm@10:   `(def ~(with-meta symbol meta-map) (quote ~expansion))))
rlm@10: 
rlm@10: (defmacro with-symbol-macros
rlm@10:   "Fully expand exprs, including symbol macros."
rlm@10:   [& exprs]
rlm@10:   `(do ~@(doall (map expand-all exprs))))
rlm@10: 
rlm@10: (defmacro deftemplate
rlm@10:   "Define a macro that expands into forms after replacing the
rlm@10:    symbols in params (a vector) by the corresponding parameters
rlm@10:    given in the macro call."
rlm@10:   [name params & forms]
rlm@10:   (let [param-map (for [p params] (list (list 'quote p) (gensym)))
rlm@10: 	template-params (vec (map second param-map))
rlm@10: 	param-map (vec (apply concat param-map))
rlm@10: 	expansion (list 'list (list 'quote `symbol-macrolet) param-map
rlm@10: 			(list 'quote (cons 'do forms)))]
rlm@10:     `(defmacro ~name ~template-params ~expansion)))
rlm@10: 
rlm@10: (defn mexpand-1
rlm@10:   "Like clojure.core/macroexpand-1, but takes into account symbol macros."
rlm@10:   [form]
rlm@10:   (binding [macro-fns {}
rlm@10: 	    macro-symbols {}
rlm@10: 	    protected-symbols #{}]
rlm@10:     (expand-1 form)))
rlm@10: 
rlm@10: (defn mexpand
rlm@10:   "Like clojure.core/macroexpand, but takes into account symbol macros."
rlm@10:   [form]
rlm@10:   (binding [macro-fns {}
rlm@10: 	    macro-symbols {}
rlm@10: 	    protected-symbols #{}]
rlm@10:     (expand form)))
rlm@10: 
rlm@10: (defn mexpand-all
rlm@10:   "Perform a full recursive macro expansion of a form."
rlm@10:   [form]
rlm@10:   (binding [macro-fns {}
rlm@10: 	    macro-symbols {}
rlm@10: 	    protected-symbols #{}]
rlm@10:     (expand-all form)))