(ns com.tailrecursion.nanopass
"Define immutable languages and emit their Typed Clojure aliases on demand.
Ordinary language loading has no Typed Clojure dependency."
(:require [com.tailrecursion.nanopass.language :as language]
[com.tailrecursion.nanopass.pass :as pass]))
(defn- description [name]
(let [v (when (symbol? name) (resolve name))]
(when-not (and (var? v) (::language (meta v)))
(language/fail :unknown-language name "Expected a nanopass language Var"))
@v))
(defmacro deflanguage
"Define named nonterminals using Typed Clojure syntax. Local references are
rebound when deriving a language; quoted singleton values remain data."
[name types]
(when-not (and (simple-symbol? name) (map? types))
(language/fail :invalid-language &form "Expected a simple language name and a type map"))
(let [qualified (symbol (str (ns-name *ns*)) (str name))
types (language/qualify *ns* (set (keys types)) types)
value (language/language qualified types)]
;; Keep each descriptor's constants in its own class during AOT compilation;
;; many derived languages otherwise overflow the namespace initializer.
`(def ~(vary-meta name assoc ::language true) ((fn [] '~value)))))
(defmacro derive-language
"Derive from a language with :remove tag sets, :add production vectors, and
:replace complete nonterminal definitions. Changes use local nonterminal names."
[name parent changes]
(when-not (and (simple-symbol? name) (map? changes))
(language/fail :invalid-extension &form "Expected a simple language name and a change map"))
(let [base (description parent)
names (set (concat (keys (:types base)) (keys (:replace changes))))
changes (language/qualify *ns* names changes)
value (language/derive (symbol (str (ns-name *ns*)) (str name)) base changes)]
`(def ~(vary-meta name assoc ::language true) ((fn [] '~value)))))
(defmacro ann-languages
"Emit checker declarations from language descriptions in an annotation-only
namespace requiring typed.clojure. This macro is unnecessary in ordinary use."
[& languages]
`(do ~@(language/type-forms (map description languages))))
(defn- pass-definition
[locals form name {:keys [from to args processors body] :as options} arguments clauses]
(when-not (and (simple-symbol? name) (vector? from) (= 2 (count from))
(symbol? (first from)) (simple-symbol? (second from))
(contains? options :to)
(or (not (vector? to)) (and (= 2 (count to)) (symbol? (first to))
(simple-symbol? (second to))))
(or (nil? args) (vector? args))
(or (nil? body) (boolean? body))
(or (nil? processors) (and (map? processors) (every? simple-symbol? (keys processors))
(every? symbol? (vals processors))))
(vector? arguments) (every? simple-symbol? arguments)
(= (count arguments) (count (set arguments)))
(= (count arguments) (inc (count args)))
(every? #{:from :to :args :processors :body} (keys options)))
(language/fail :invalid-pass form "Invalid pass name, signature, or options"))
(let [source (description (first from))
target (when (vector? to) (description (first to)))
result-type (if target (language/type-name target (second to))
(language/qualify *ns* #{} to))]
(with-meta (pass/definition
{:name (symbol (str (ns-name *ns*)) (str name))
:source source :target target :from (second from) :to (when target (second to))
:params (mapv #(language/qualify *ns* #{} %) args) :arguments arguments
:result-type result-type
:processors (into (if-let [self (locals name)] {(second from) self} {})
(map (fn [[nt processor]] [nt (or (locals processor) (language/qualify *ns* #{} processor))])) processors)
:body? body}
clauses) (meta form))))
(defmacro defpass
"Define a checked pass. :from and :to identify [language nonterminal]; :to may
instead be a result type. :args types the leading context parameters. Supply
tag/expression clauses; unchanged productions get structural recursion through
:processors (nonterminal -> function). :body true accepts one explicit body."
[name options arguments & clauses]
(pass-definition #{} &form name options arguments clauses))
(defmacro defpasses
"Define mutually recursive processors as one lexical letfn group. Each entry
has the defpass syntax without its macro name. All functions retain their
individual checker signatures; recursion uses locals, not forward Vars."
[& definitions]
(let [names (map first definitions) locals (set names)]
(when-not (and (seq definitions) (every? simple-symbol? names)
(= (count names) (count locals)))
(language/fail :invalid-pass &form "Expected distinct processor names"))
;; Typed Clojure 1.3 collects letfn bindings in a map before matching its
;; positional annotations. Emit that same order, including groups over eight.
(let [functions
(vals
(into {}
(for [[name options arguments & clauses :as form] definitions
:let [captures (into {} (for [arg arguments :when (locals arg)] [arg (gensym "processor__")]))
processors (merge (zipmap names names) captures)
[_ id attributes args body] (pass-definition processors form name options arguments clauses)
parameters (mapv #(if (captures %) (with-meta (gensym "argument__") (meta %)) %) args)
;; Save shadowed processors before restoring source parameter names.
body (if (seq captures)
`(let [~@(mapcat (fn [[name saved]] [saved name]) captures)
~@(mapcat (fn [arg parameter]
(when (not= arg parameter) [(with-meta arg nil) parameter])) args parameters)]
~body) body)]]
[name (with-meta (list 'defn id (assoc attributes :arglists (list 'quote (list args))) parameters body)
(meta form))])))
signatures (mapv #(second (::signature (nth % 2))) functions)]
`(letfn [~@(map (fn [[_ name _ args body :as form]]
(with-meta (list name args body) (meta form))) functions)]
;; Typed Clojure's letfn annotation is an inert quoted vector, in
;; binding order. It imposes no checker dependency at runtime.
'~signatures
~@(map (fn [[_ name attributes :as form]]
`(def ~(with-meta name (merge (meta form) attributes)) ~name)) functions)))))
(defmacro ann-passes
"Emit checker signatures stored by defpass. The generated function bodies
must additionally be checked with Typed Clojure's check-ns-clj."
[& passes]
`(do ~@(for [name passes
:let [v (resolve name) signature (::signature (meta v))]]
(do (when-not signature
(language/fail :unknown-pass name "Expected a defined nanopass function"))
(list 'typed.clojure/ann
(symbol (str (ns-name (:ns (meta v)))) (str (:name (meta v)))) signature)))))