(ns com.tailrecursion.blacktide.case-test
"Compare native case dispatch, then attack unique arms, lexical joins and
pending evaluation. Constants are deliberately not interpreted with ordinary =."
(:require [clojure.test :refer [deftest is]]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[clojure.walk :as walk]
[com.tailrecursion.blacktide :refer [loophole setq psetq label goto]]
[com.tailrecursion.blacktide.compiler.passes.lower :as lower]
[com.tailrecursion.blacktide.jvm-fixture :as jvm]
[com.tailrecursion.blacktide.backend-fixture :as backend]))
(defn compile-function [form]
(binding [*ns* (the-ns 'com.tailrecursion.blacktide.case-test)]
(eval (list 'fn ['input] form))))
(defn result [f value]
(try {:value (f value)} (catch Throwable error {:error (class error) :message (ex-message error)})))
(deftest constants-match-native-dispatch
(let [tables ['[1 :integer]
'[:a :keyword nil :nil false :false true :true]
'["Aa" :aa "BB" :bb "AaAa" :aaaa "BBBB" :bbbb]
'[alpha :alpha beta :beta]
'[\a :character \newline :newline]
'[1N :bigint 1M :decimal 1/2 :ratio 4294967297 :large]
'[nil :nil [1 2] :vector {:a 1} :map #{1 2} :set]
'[1 :one :a :keyword "Aa" :string \a :character nil :nil false :false]
'[(1 2) :integers ("Aa" "BB") :strings (alpha beta) :symbols]
(vec (mapcat (fn [n] [n (* n n)]) (range 96)))]
values [nil false true -1 0 1 2 (int 1) (byte 1) 1N 1M 1.0 (float 1) 1/2
4294967297 95 96 :a :missing 'alpha 'beta 'String "Aa" "BB" "AaAa" "BBBB" "other"
\a \newline [1 2] '(1 2) {:a 1} #{1 2} String]]
(doseq [table tables default? [true false]]
(let [form (list* 'case 'input (cond-> table default? (conj :default)))
expected (compile-function form) actual (compile-function (list 'loophole [] form))]
(doseq [value values]
(is (= (result expected value) (result actual value)) (pr-str {:table table :default? default? :value value})))))))
(deftest dispatch-effects-and-branch-results
(is (= 10 (loophole [x 0]
(case (do (setq x (inc x)) x) 1 (setq x 10) 2 (setq x 20) (setq x 30)) x)))
(let [events (atom [])]
(is (= [1 30 40 40]
(loophole [x 0]
[(do (setq x 1) x)
(case (do (swap! events conj :dispatch) (setq x 2))
1 (do (swap! events conj :wrong) (setq x 10))
2 (do (swap! events conj :chosen) (+ (setq x 10) (setq x 20)))
(setq x 99))
(setq x 40) x])))
(is (= [:dispatch :chosen] @events)))
(is (= [9 nil 3]
(loophole [x 1 y 2]
[(case x 1 (setq x (case y 2 9 0)) 0)
(case x 9 (psetq x 3 y x) 0) x])))
(is (= 0 (loophole [x 0] (case (setq x 1) :default) (setq x 0))))
(is (= [:string :long :object :object]
(loophole [x 1]
[(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser (case x 1 "x" "y"))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser (case x 1 2 3))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser (case x 1 true false))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser (case x 1 2 nil))]))))
(deftest case-jumps-do-not-fall-through
(is (= :done (loophole []
(case :a (:a :b :c) (goto done) :wrong)
(throw (Exception. "fell through")) (label done) :done)))
(is (= [3 [0 1 2 3]]
(loophole [n 0 trace []]
(label again)
(case (do (setq trace (conj trace n)) n)
(0 1 2) (do (setq n (inc n)) (goto again))
3 :done)
[n trace]))))
(deftest cases-and-original-loops
(is (= [3 6] (loophole [sum 0]
(loop [i 0]
(case i
(0 1 2) (do (setq sum (+ sum i)) (recur (inc i)))
3 (do (setq sum (+ sum i)) [i sum]))))))
(doseq [form '[(loop [i 3] (case i 0 :done (recur (dec i))))
(loop [i 1] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser (case i 1 i 0)))
(loop [i 1] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser (case i 1 "a" nil)))
(loop [i 0] (case i 0 (let [i 1] (case i 1 :yes :no)) :wrong))]]
(is (= (jvm/outcome form) (jvm/outcome (list 'loophole [] form))) (pr-str form)))
(is (= :done (loophole [] (loop [i 1] (case i 0 :done (do (setq) (psetq) (recur 0))))))))
(defmacro env-size [] (count &env))
(defmacro dispatch-local [] (first (keys &env)))
(def expansions (atom []))
(defmacro expanded [tag value] (swap! expansions conj tag) value)
(deftest case-macro-environments-and-initialization
(reset! expansions [])
(is (= :group
(backend/run-form
'(com.tailrecursion.blacktide/loophole []
(case :a
(:a :b) (com.tailrecursion.blacktide.case-test/expanded :group :group)
"Aa" (com.tailrecursion.blacktide.case-test/expanded :aa :aa)
"BB" (com.tailrecursion.blacktide.case-test/expanded :bb :bb)
(com.tailrecursion.blacktide.case-test/expanded :default :default))))))
(is (= [:group :aa :bb :default] @expansions))
(let [body '(let [x 0] (case input 1 (env-size) :other))]
(is (= (result (compile-function body) 1) (result (compile-function (list 'loophole [] body)) 1))))
(binding [*ns* (the-ns 'com.tailrecursion.blacktide.case-test)]
(is (= 1 (eval '(loophole [] (case 1 1 (dispatch-local))))))
(let [form '(loophole [] (goto body) (case 1 1 (do (label body) (dispatch-local))))]
(is (= :marker-position
(try (eval form) nil
(catch Throwable error
(:kind (ex-data (backend/root-error error))))))))))
(deftest native-case-errors-and-source-validation
(doseq [form '[(case 1 1 :a 1 :b)
(case 1 (1 2) :a 2 :b)
(case 1 1 :a 1N :b)
(case 0 () :empty :other)
(case 0)]]
(is (= (:error (jvm/outcome form)) (:error (jvm/outcome (list 'loophole [] form)))) (pr-str form)))
;; The public diagnostic contract distinguishes a missing dispatch expression
;; from core case's constant/default errors.
(is (= :invalid-case (:kind (backend/rejection '(loophole [] (case))))))
(is (= :marker-position (:kind (backend/rejection '(loophole [] (case 1 1 (label same) 2 (label same)))))))
(is (= :undefined-label (:kind (backend/rejection '(loophole [] (case 1 1 :ok 2 (goto missing)))))))
(is (= :marker-position
(:kind (backend/rejection '(loophole [] (goto inside) (+ 1 (case 0 0 (do (label inside) 2) 3)))))))
(is (= :invalid-recur (:kind (backend/rejection '(loophole [] (loop [] (inc (case 0 0 (recur) 1)))))))))
(deftest prepared-dispatch-and-expansion-equivalence
(let [form '(loophole [x 0 out []]
(label again)
(case (do (swap! events conj x) x)
2 (goto done)
(0 1) (setq out (conj out x) x (inc x))
(throw (Exception. "unexpected default")))
(goto again)
(label done) out)
graph (backend/capture #'lower/stage form)]
(is (= 1 (count (filter #(= :switch (:op (:term %))) (vals (:blocks graph)))))
"Compiler-generated ordinal selection goes directly to the source arms")
(doseq [mode [:default :dispatcher]]
(is (= {:value [0 1] :trace [0 1 2]} (backend/execution form mode)))))
(doseq [body '[(case input 0 :zero 2 :two :other)
(case input "Aa" :aa "BB" :bb :other)
(case input (:a :b) :group nil :nil :other)
(case input [1 2] :sequential :other)
(case input 1N :one 1M :decimal :other)]
:let [expanded (binding [*ns* (the-ns 'com.tailrecursion.blacktide.case-test)] (macroexpand-1 body))
expected (compile-function body) actual (compile-function (list 'loophole [] expanded))]
value [nil :a :b 0 1 1N 1M 2 "Aa" "BB" "missing" [1 2] '(1 2)]]
(is (= (result expected value) (result actual value)) (pr-str {:body body :input value})))
(is (= [7 3]
(loophole [x 0]
[(+ (setq x 1) (case (setq x 2) 2 (setq x 3) 99) x) x])))
(is (= [3 :text true]
(loophole [x nil out []]
(dotimes [i 3]
(case i 0 (setq x 3) 1 (setq x :text) (setq x true))
(setq out (conj out x))) out)))
(doseq [body '[(case input 1 "x" (throw (Exception. "missing")))
(case input 1 (long 2) (long 3))
(case input 1 (boolean true) (boolean false))
(case input 1 "x" nil)
(case input 1 nil "x")]]
(let [form (list 'let '[input 1]
(list '.choose (with-meta 'chooser {:tag 'com.tailrecursion.blacktide.jvm_fixture.Choice}) body))]
(is (= (jvm/outcome form) (jvm/outcome (list 'loophole [] form)))))))
(defn command-model [{:keys [tokens a b weight width]}]
;; Independent transitions on an input tape; no labels, assignment lowering,
;; dispatch ordinals or production compiler representation participate.
(loop [i 0 m a n b out []]
(if (= i (count tokens)) [m n i out]
(let [token (nth tokens i) snapshot m i (inc i)
delta (cond (= 0 (mod m 3)) weight (= 1 (mod m 3)) (- weight) :else 0)]
(cond
(= :stop token) [m n i out]
(= :skip token) (recur i m n out)
:else
(let [[m n] (cond
(or (= :swap token) (= \s token)) [n m]
(= :add token) [(+ m delta) (+ n m delta)]
(= "Aa" token) [(+ m (reduce + 0 (map #(+ delta %) (range width)))) n]
(= "BB" token) [(if (even? n) (+ m delta) (- m delta)) m]
(nil? token) [(if (zero? snapshot) 7 snapshot) n]
:else [m (- n delta)])]
(recur i m n (conj out [i snapshot m n]))))))))
(defn command-program [{:keys [tokens a b weight width]}]
`(loophole [~'m ~a ~'n ~b ~'i 0 ~'out []]
(label ~'scan)
(when (= ~'i ~(count tokens)) (goto ~'finished))
(let [~'snapshot ~'m ~'token (nth ~tokens ~'i)
~'delta (case (mod ~'snapshot 3) 0 ~weight 1 (- ~weight) 0)]
(setq ~'i (inc ~'i))
(case ~'token
(:swap \s) (psetq ~'m ~'n ~'n ~'m)
:add (setq ~'m (+ ~'m ~'delta) ~'n (+ ~'n ~'m))
"Aa" (loop [~'snapshot 0]
(when (< ~'snapshot ~width)
(setq ~'m (+ ~'m ~'delta ~'snapshot)) (recur (inc ~'snapshot))))
"BB" (psetq ~'m (case (mod ~'n 2) 0 (+ ~'m ~'delta) (- ~'m ~'delta)) ~'n ~'m)
:stop (goto ~'finished)
:skip (goto ~'scan)
nil (setq ~'m (case ~'snapshot 0 7 ~'snapshot))
(setq ~'n (- ~'n ~'delta)))
(setq ~'out (conj ~'out [~'i ~'snapshot ~'m ~'n])))
(goto ~'scan)
(label ~'finished) [~'m ~'n ~'i ~'out]))
(defn command-outcome [config wrap]
(try {:value (backend/run-form (wrap (command-program config)))}
(catch Throwable error {:error (class error) :message (ex-message error)})))
(defspec generated-case-loop-jump-programs {:num-tests 120 :seed 173205}
(prop/for-all [config (gen/hash-map
:tokens (gen/vector (gen/elements [:swap \s :add "Aa" "BB" :stop :skip nil :other]) 0 24)
:a (gen/choose -10 10) :b (gen/choose -10 10)
:weight (gen/choose -3 3) :width (gen/choose 0 5))]
(every? true?
(for [wrap [identity #(list 'do (walk/postwalk-replace '{m left n right scan again finished done snapshot saved} %))]]
(= {:value (command-model config)} (command-outcome config wrap))))))