(ns com.tailrecursion.nanopass.check
"Compile-time probes for generated recursive languages."
(:require [clojure.test :refer [deftest is]]
[clojure.core.typed :as checker]
[typed.clojure :as t]
[com.tailrecursion.nanopass :as np]
[com.tailrecursion.nanopass.pipeline :as pipeline]
[com.tailrecursion.nanopass.annotations]
[com.tailrecursion.nanopass.fixtures :as f]
[com.tailrecursion.nanopass.passes :as p]))
(defn check-form [form expected]
(binding [*ns* (the-ns 'com.tailrecursion.nanopass.check)
*err* (java.io.StringWriter.)]
(checker/check-form-info form :expected expected :type-provided? true
:check-config {:check-form-eval :never})))
(defn checks? [expected form accepted]
(let [{:keys [ex delayed-errors]} (check-form form expected)
errors (concat delayed-errors (:errors (ex-data ex)))]
(is (or (nil? ex) (= :top-level-error (:type-error (ex-data ex)))) (str ex))
(is (= accepted (empty? errors)) (pr-str [form errors]))))
(defn accepts? [expected form accepted]
(checks? expected (list 'quote form) accepted))
(deftest recursive-languages
(doseq [[accepted form]
[[true {:op :literal :value '{:op :assign :value Expr}}]
[true {:op :write :name 'x :value {:op :literal :value 42}}]
[false {:op :assign :binding {:op :binding :name 'x :value {:op :literal :value 1}}
:value {:op :literal :value 2}}]
[false {:op :group :bindings [{:op :binding :name 'x
:value {:op :assign :binding {:op :binding :name 'y
:value {:op :literal :value 1}}
:value {:op :literal :value 2}}}]
:body {:op :literal :value nil}}]
[false {:op :write :name 42 :value {:op :literal :value nil}}]
[false {:op :literal :value 1 :extra true}]]]
(accepts? 'f/Core-Expr form accepted)))
(deftest recursive-containers
(let [leaf {:op :literal :value 1}
bad {:op :assign :binding {:op :binding :name 'x :value leaf} :value leaf}
base {:op :many :items {} :pair [leaf nil] :unique #{}}]
(doseq [form [base (assoc base :note "ok")
(assoc base :items {:a [leaf]} :pair [leaf leaf] :unique #{leaf})]]
(accepts? 'f/Core-Expr form true))
(doseq [form [(assoc base :items {:a [bad]}) (assoc base :pair [bad nil])
(assoc base :pair [leaf bad]) (assoc base :unique #{bad})
(assoc base :note 42)]]
(accepts? 'f/Core-Expr form false))))
(deftest indirect-recursion
(accepts? 'f/Mutual-A {:op :a :next {:op :b :next {:op :a :next nil}}} true)
(accepts? 'f/Stopped-A {:op :a :next {:op :stop}} true)
(accepts? 'f/Stopped-A {:op :a :next {:op :b :next nil}} false))
(deftest checked-passes
(is (t/check-ns-clj 'com.tailrecursion.nanopass.pipeline))
(is (t/check-ns-clj 'com.tailrecursion.nanopass.passes)))
(deftest pipeline-contracts
(doseq [[accepted form]
[[true '(fn [state tree]
(->> [state tree]
(pipeline/map-value p/lower)
(apply p/count-step)))]
[false '(fn [state tree]
(->> [state tree]
(pipeline/map-value p/lower)
(pipeline/map-value p/lower)))]
[false '(fn [state tree]
(->> [state tree]
(pipeline/map-value p/lower)
(apply (fn [state tree] [tree state]))))]]]
(checks? '[t/Int f/Source-Expr :-> (t/HVec [t/Int f/Core-Expr])] form accepted)))
(defn generated-function [clause]
(let [[_ _ _ args body]
(binding [*ns* (the-ns 'com.tailrecursion.nanopass.passes)]
(macroexpand-1
(list 'np/defpass 'lower
'{:from [f/Source Expr] :to [f/Core Expr] :processors {Binding lower-binding}}
'[node] :assign clause)))]
(list 'fn args body)))
(deftest generated-negative-probes
(let [good (generated-function '{:op :write :name (:name (:binding node))
:value (p/lower (:value node))})
[f args [case-op test & arms]] good
missing (list f args (list* case-op test
(concat (mapcat identity (remove #(= :assign (first %))
(partition 2 (butlast arms))))
[(last arms)])))]
(doseq [[accepted form]
[[true good]
[false missing]
[false (generated-function 'node)]
[false (generated-function '{:op :write :name 42 :value (p/lower (:value node))})]
[false '(fn [node] (p/lower (p/lower node)))]]]
(checks? '[f/Source-Expr :-> f/Core-Expr] form accepted))))
(deftest recursive-processor-bodies-are-checked
(doseq [[accepted value] [[true '(:value node)] [false 'node]]]
(let [definitions
(concat
[(list 'expression '{:from [f/Source Binding] :to [f/Core Binding] :body true}
'[node] '(binding node))
(list 'binding '{:from [f/Source Binding] :to [f/Core Binding]}
'[node] :binding {:op :binding :name '(:name node) :value (list 'p/lower value)})]
;; Distinct contracts across the array-map/hash-map boundary catch
;; positional annotations attached to the wrong letfn processor.
(for [i (range 9)]
(list (symbol (str "constant" i)) {:from '[f/Source Expr] :to (list 't/Val i) :body true}
'[node] i)))
[head bindings signatures]
(binding [*ns* (the-ns 'com.tailrecursion.nanopass.check)]
(macroexpand-1 (cons 'np/defpasses definitions)))
form (list head bindings signatures 'expression)]
(checks? '[f/Source-Binding :-> f/Core-Binding] form accepted))))