(ns com.tailrecursion.nanopass.language
"Immutable language descriptions from public Typed Clojure type syntax.
Local nonterminals remain symbolic until aliases are emitted for a language."
(:refer-clojure :exclude [derive])
(:require [clojure.set :as set]))
(defn fail [kind form message & [details]]
(throw (ex-info message (merge {:kind kind :form form :file *file*}
(select-keys (meta form) [:line :column]) details))))
(defn literal-type? [form]
(and (seq? form) (#{'quote 'typed.clojure/Val 'typed.clojure/Value} (first form))))
(defn- qualified-type-name [sym]
(if (= "clojure.core.typed" (namespace sym))
(symbol "typed.clojure" (name sym)) sym))
(defn qualify
"Resolve type names in the defining namespace; leave local nonterminals and
singleton quoted values intact. No checker is loaded or consulted."
[caller nonterminals form]
(cond
(and (seq? form) (= 'quote (first form)))
(if (and (= 2 (count form)) (not (coll? (second form)))) form
(fail :unsupported-type form "Use explicit HMap/HVec types, or Val for a literal collection"))
(symbol? form)
(cond
(nonterminals form) form
(namespace form) (qualified-type-name
(if-let [alias (get (ns-aliases caller) (symbol (namespace form)))]
(symbol (str (ns-name alias)) (name form)) form))
:else (let [v (ns-resolve caller form)]
(cond (class? v) (symbol (.getName ^Class v))
(var? v) (symbol (str (ns-name (:ns (meta v)))) (str (:name (meta v))))
:else (fail :unknown-type form "Unknown type or nonterminal"))))
(seq? form) (let [op (qualify caller nonterminals (first form))]
(if (#{'typed.clojure/Val 'typed.clojure/Value} op)
(cons op (rest form))
(cons op (map #(qualify caller nonterminals %) (rest form)))))
(vector? form) (mapv #(qualify caller nonterminals %) form)
(map? form) (into (empty form) (map (fn [[k v]] [k (qualify caller nonterminals v)])) form)
:else form))
(defn hmap-options [form]
(when (= 'typed.clojure/HMap (first form))
(let [options (rest form)]
(when (or (odd? (count options))
(not= (count (take-nth 2 options)) (count (set (take-nth 2 options)))))
(fail :invalid-hmap form "HMap options must be distinct key/value pairs"))
(apply hash-map options))))
(defn children
"Immediate type children in supported structural constructors. nil means an
opaque terminal type, whereas an empty vector means a known leaf structure."
[form]
(when (seq? form)
(case (first form)
typed.clojure/HMap (let [{:keys [mandatory optional]} (hmap-options form)]
(vec (concat (vals mandatory) (vals optional))))
typed.clojure/HVec (second form)
(typed.clojure/U typed.clojure/Vec typed.clojure/Map
typed.clojure/Set typed.clojure/Option) (vec (rest form))
nil)))
(defn references [nonterminals form]
(into #{} (filter nonterminals)
(tree-seq #(and (coll? %) (not (literal-type? %))) seq form)))
(defn tag [form]
(when (and (seq? form) (= 'typed.clojure/HMap (first form)))
(let [value (get-in (hmap-options form) [:mandatory :op])]
(when (and (literal-type? value) (= 2 (count value)) (keyword? (second value)))
(second value)))))
(defn alternatives [form]
(if (and (seq? form) (= 'typed.clojure/U (first form)))
(vec (mapcat alternatives (rest form))) [form]))
(defn- validate-type [nonterminals form]
(when (seq? form)
(case (first form)
typed.clojure/HMap
(let [{:keys [mandatory optional complete?] :as options} (hmap-options form)]
(when-not (and (true? complete?)
(every? #{:mandatory :optional :complete?} (keys options))
(or (nil? mandatory) (map? mandatory))
(or (nil? optional) (map? optional))
(every? keyword? (concat (keys mandatory) (keys optional))))
(fail :invalid-hmap form "Structural maps need keyword fields and :complete? true"))
(when (seq (set/intersection (set (keys mandatory)) (set (keys optional))))
(fail :invalid-hmap form "Required and optional fields must be disjoint"))
(when (or (contains? optional :op) (and (contains? mandatory :op) (nil? (tag form))))
(fail :invalid-tag form "An :op field must be a required quoted keyword")))
typed.clojure/HVec
(when-not (and (= 2 (count form)) (vector? (second form)))
(fail :invalid-tuple form "Use a fixed HVec vector without options"))
(typed.clojure/Vec typed.clojure/Set typed.clojure/Option)
(when-not (= 2 (count form)) (fail :invalid-type form "Expected one type argument"))
typed.clojure/Map
(when-not (= 3 (count form)) (fail :invalid-type form "Expected key and value types"))
typed.clojure/U
(let [tags (keep tag (alternatives form))]
(when-not (= (count tags) (count (set tags)))
(fail :duplicate-tag form "Union production tags must be distinct")))
nil))
(if-let [parts (children form)]
(doseq [child parts] (validate-type nonterminals child))
(when (and (not (nonterminals form)) (seq (references nonterminals form)))
(fail :unsupported-recursion form "Nonterminal occurs in an unsupported type constructor"))))
(defn language [name types]
(when-not (and (qualified-symbol? name) (map? types) (seq types)
(every? simple-symbol? (keys types)))
(fail :invalid-language types "A language needs a qualified name and named nonterminals"))
(let [nonterminals (set (keys types))]
(doseq [[_ type] types] (validate-type nonterminals type)))
{:name name :types (into (sorted-map) types)})
(defn derive [name base {:keys [remove add replace] :as changes}]
(when-not (every? #{:remove :add :replace} (keys changes))
(fail :invalid-extension changes "Expected :remove, :add, or :replace"))
(let [types (:types base)
removed-or-added (set (concat (keys remove) (keys add)))]
(when (seq (set/intersection removed-or-added (set (keys replace))))
(fail :invalid-extension changes "Replace cannot also add/remove the same nonterminal"))
(doseq [nt removed-or-added]
(when-not (contains? types nt)
(fail :unknown-nonterminal nt "Add/remove needs an existing nonterminal")))
(language name
(merge
(reduce
(fn [types nt]
(let [old (alternatives (get types nt))
tags (set (map tag old))
removed (get remove nt #{})
added (get add nt [])]
(when-not (and (set? removed) (vector? added)
(not (contains? tags nil)) (every? tag added))
(fail :invalid-extension nt "Add/remove applies to tagged productions"))
(when-not (set/subset? removed tags)
(fail :unknown-production removed "Cannot remove a production that is absent"))
(assoc types nt (list* 'typed.clojure/U
(concat (clojure.core/remove #(removed (tag %)) old) added)))))
types removed-or-added)
replace))))
(defn type-name [{:keys [name types]} nonterminal]
(when-not (contains? types nonterminal)
(fail :unknown-nonterminal nonterminal "Language has no such nonterminal" {:language name}))
(symbol (namespace name) (str (clojure.core/name name) "-" nonterminal)))
(defn instantiate
"Replace local nonterminals with this language's aliases, preserving quoted
singleton data. Used for checker declarations and pass signatures."
([language form] (instantiate language {} form))
([{:keys [types] :as language} bound form]
(cond
(literal-type? form) form
(and (symbol? form) (contains? types form)) (get bound form (type-name language form))
(seq? form) (apply list (map #(instantiate language bound %) form))
(vector? form) (mapv #(instantiate language bound %) form)
(map? form) (into (empty form) (map (fn [[k v]] [k (instantiate language bound v)])) form)
:else form)))
(defn type-forms [languages]
;; Rec prevents container-kind checks from expanding recursive aliases forever.
;; Cross-nonterminal aliases are registered before any pass is checked.
(for [language languages [nt type] (:types language)]
(list 'typed.clojure/defalias (type-name language nt)
(list 'typed.clojure/Rec [nt] (instantiate language {nt nt} type)))))