(ns com.tailrecursion.nanopass.pass
"Generate ordinary checked functions for a declared language transformation.
Structural defaults recurse only through explicit nonterminal positions."
(:require [com.tailrecursion.nanopass.language :as l]))
(defn- typed [sym type]
(vary-meta sym assoc :typed.clojure/- type))
(defn- unexpected [pass value]
(let [bad (gensym "unhandled__")]
`((fn [~(typed bad 'typed.clojure/Nothing)] (throw (ex-info "Unexpected nanopass production"
{:pass '~pass :node ~bad}))) ~value)))
(defn- preserve-meta [{:keys [target]} type value result]
(let [type (l/instantiate target type)
id (gensym "result__")
attach (with-meta 'clojure.core/with-meta
{:typed.clojure/inst [(list 'typed.clojure/I 'clojure.lang.IObj type)]})]
`(let [~(typed id type) ~result]
(if (instance? clojure.lang.IObj ~id)
(~attach ~id (meta ~value))
~id))))
(defn definition
[{:keys [name source target from to params arguments result-type processors body?]} forms]
(letfn [(mapper [{:keys [source] :as context} in out]
(let [item (gensym "item__")]
`(fn [~(typed item (l/instantiate source in))] ~(walk context in out item))))
(map-fields [{:keys [source target] :as context} in out value]
(let [a (l/hmap-options in) b (l/hmap-options out)]
(when-not (every? #(= (set (keys (% a))) (set (keys (% b)))) [:mandatory :optional])
(l/fail :explicit-clause-required in "Changed map fields need an explicit clause"))
(let [changed (filter (fn [[key type]]
(or (not= type (get-in b [:optional key]))
(seq (l/references (set (keys (:types source))) type))))
(sort-by (comp str key) (:optional a)))
base (if (seq changed) `(dissoc ~value ~@(map first changed)) value)
fields (mapcat (fn [[key type]]
(let [before `(~key ~value)
after (walk context type (get-in b [:mandatory key]) before)]
(when (not= before after) [key after]))) (:mandatory a))
required (if (seq fields) `(assoc ~base ~@fields) base)]
;; assoc/dissoc preserve metadata. Retain unchanged fields and reconstruct
;; only recursive or changed fields; no metadata wrapper is needed.
(reduce (fn [result [key type]]
(let [acc (gensym "record__") child (gensym "child__")
other-keys (remove #{key} (concat (keys (:mandatory a)) (keys (:optional a))))]
;; Project a zero/one-entry map. Its value type excludes
;; missing-key nil while retaining an explicitly present nil.
`(reduce-kv
(fn [~(typed acc (l/instantiate target out)) ~'_ ~(typed child (l/instantiate source type))]
(assoc ~acc ~key ~(walk context type (get-in b [:optional key]) child)))
~result (dissoc ~value ~@other-keys))))
required changed))))
(optional [context in out value]
(let [id (gensym "optional__")]
`((fn [~(typed id (list 'typed.clojure/Option (l/instantiate (:source context) in)))]
(if (nil? ~id) nil ~(walk context in out id))) ~value)))
(walk [{:keys [source target processors params] :as context} in out value]
(cond
(and (symbol? in) (contains? (:types source) in))
(if-let [processor (and (contains? (:types target) out) (get processors in))]
`(~processor ~@params ~value)
(l/fail :missing-processor in "Recursive field needs a processor" {:target out}))
(and (= in out) (empty? (l/references (set (keys (:types source))) in))) value
(not (and (seq? in) (seq? out) (= (first in) (first out))))
(l/fail :explicit-clause-required in "Changed field types need an explicit clause" {:target out})
:else
(case (first in)
typed.clojure/HMap (map-fields context in out value)
typed.clojure/Vec (preserve-meta context out value `(mapv ~(mapper context (second in) (second out)) ~value))
typed.clojure/Set (preserve-meta context out value `(into #{} (map ~(mapper context (second in) (second out))) ~value))
typed.clojure/HVec
(do (when-not (= (count (second in)) (count (second out)))
(l/fail :explicit-clause-required in "Changed tuple arity needs an explicit clause"))
(preserve-meta context out value
(mapv (fn [i a b] (walk context a b `(nth ~value ~i)))
(range) (second in) (second out))))
typed.clojure/Map
(let [[_ ik iv] in [_ ok ov] out
acc (gensym "map__") k (gensym "key__") v (gensym "val__")]
(preserve-meta context out value
`(reduce-kv (fn [~(typed acc (l/instantiate target out))
~(typed k (l/instantiate source ik))
~(typed v (l/instantiate source iv))]
(assoc ~acc ~(walk context ik ok k) ~(walk context iv ov v))) {} ~value)))
typed.clojure/Option (optional context (second in) (second out) value)
typed.clojure/U
(let [a (l/alternatives in) b (l/alternatives out)]
(if (and (= 2 (count a) (count b)) (some nil? a) (some nil? b))
(optional context (first (remove nil? a)) (first (remove nil? b)) value)
(dispatch context in out value {})))
(l/fail :explicit-clause-required in "Cannot derive structural traversal for this type"))))
(dispatch [{:keys [name] :as context} in out value clauses]
(let [variants (l/alternatives in)
tags (set (map l/tag variants))
targets (when out (into {} (map (juxt l/tag identity)) (l/alternatives out)))]
(when (contains? tags nil)
(l/fail :ambiguous-dispatch in "Dispatch needs tagged map alternatives; use :body true"))
(when-not (every? tags (keys clauses))
(l/fail :unknown-production clauses "Pass clause is absent from the input language"))
`(case (:op ~value)
~@(mapcat (fn [variant]
(let [tag (l/tag variant)]
[tag (if (contains? clauses tag) (get clauses tag)
(if-let [other (get targets tag)]
(walk context variant other value)
(l/fail :missing-clause variant "Removed production needs a clause"
{:pass name :production tag})))])) variants)
~(unexpected name value))))]
(let [node (last arguments)
input-type (l/type-name source from)
signature (vec (concat params [input-type :-> result-type]))
context {:name name :source source :target target
:processors (merge {from name} processors) :params (vec (butlast arguments))}
in (get-in source [:types from]) out (get-in target [:types to])
body (if body?
(do (when-not (= 1 (count forms))
(l/fail :invalid-pass forms "A whole-body pass needs one expression"))
(first forms))
(do (when (or (odd? (count forms))
(not= (count (take-nth 2 forms)) (count (set (take-nth 2 forms)))))
(l/fail :invalid-pass forms "Pass clauses must be distinct tag/expression pairs"))
(if (and (empty? forms) (not-every? l/tag (l/alternatives in)))
(walk context in out node)
(dispatch context in out node (apply hash-map forms)))))
local-name (symbol (clojure.core/name name))]
`(defn ~local-name
{:com.tailrecursion.nanopass/signature '~signature}
~arguments ~body))))