(ns com.tailrecursion.blacktide.assignment-test
"Assignment semantics, saved operands, and independent interpreter comparisons."
(:require [clojure.test :refer [deftest is]]
[clojure.test.check :as tc]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[com.tailrecursion.blacktide :as lh :refer [loophole setq psetq]]
[com.tailrecursion.blacktide.backend-fixture :as backend]
[com.tailrecursion.blacktide.assignment-model :as oracle]))
(defn add [a b] (+ a b))
(defn event! [events tag value] (swap! events conj [tag value]) value)
(deftest batch-results-and-repeated-targets
(is (= [nil nil] (loophole [] [(setq) (psetq)])))
(is (= [2 1] (loophole [x 1 y 2] (psetq x y y x) [x y])))
(is (= [3 3 3] (loophole [x 1 y 2] [(setq x 3 y x) x y])))
(is (= [nil 2 2] (loophole [x 1 y 2] [(psetq x 9 x y) x y])))
(is (= [2 9] (loophole [x 1 y 2] (psetq x y y (setq x 9)) [x y])))
(is (= [1 2] (loophole [x 1 y 2] (psetq x (do (psetq x y y x) y) y x) [x y])))
(is (= "changed" (loophole [x 1] (setq x 2.5 x "changed") x)))
(is (= [1 10 10 10] (loophole [x 1] (let [a x b (setq x 10) c x] [a b c x])))))
(deftest operand-and-assignment-snapshots
(is (= 30 (loophole [x 0] (add (do (setq x 10) x) (do (setq x 20) x)))))
(is (= [1 10 10 20] (loophole [x 1] [x (setq x 10) x (setq x 20)])))
(is (= [3 9] (loophole [x 1] [(add x (setq x 2)) (setq x 9)])))
(is (= 7 (loophole [f add] (f (do (setq f vector) 3) 4))))
(is (= [nil 1 8] (loophole [x 1 y 2] [(psetq x (setq y 8) y x) y x]))))
(deftest writes-in-collections-and-metadata
(is (= #{1 2} (loophole [x 0] #{(setq x 1) (setq x 2)})))
(is (= [{1 2} 2] (loophole [x 1] [{x (setq x 2)} x])))
(is (= [[1] 9 {:note 9}]
(loophole [x 1] (let [v ^{:note (setq x 9)} [x]] [v x (meta v)])))))
(deftest initialization-and-abandonment
(is (= [1 9 9] (loophole [x 1 before x y (setq x 9)] [before x y])))
(let [events (atom []) fail (fn [x] (event! events :before-throw x) (throw (ex-info "stop" {})))]
(is (thrown-with-msg? clojure.lang.ExceptionInfo #"stop"
(loophole [x 1 y 2] (psetq x (event! events :first 10) y (fail x)))))
(is (= [[:first 10] [:before-throw 1]] @events))
(reset! events [])
(is (thrown-with-msg? clojure.lang.ExceptionInfo #"stop"
(loophole [x 1 y 2]
(psetq x (event! events :first 10)
y (do (setq x 9) (fail x))))))
(is (= [[:first 10] [:before-throw 9]] @events)))
(let [events (atom [])]
(is (= [nil 2 1]
(loophole [x 1 y 2] [(psetq x (event! events :first y) y (event! events :second x)) x y])))
(is (= [[:first 2] [:second 1]] @events))))
(deftest assignment-diagnostics-and-shadowing
(doseq [[body kind] [['(setq x) :invalid-assignment]
['(psetq x 1 y) :invalid-assignment]
['(setq ns/x 1) :invalid-assignment]
['(setq [x] 1) :invalid-assignment]
['(psetq missing 1) :unknown-assignment]
['(let [x 3] (setq x 4)) :immutable-assignment]]]
(is (= kind (:kind (backend/rejection (list 'loophole '[x 1] body))))))
(is (= [1 2] (loophole [setq vector] (setq 1 2))))
(is (= [3] (loophole [psetq vector] (psetq 3))))
(is (= :immutable-assignment (:kind (backend/rejection '(let [outside 1] (loophole [] (setq outside 2)))))))
(is (= 2 (loophole [x 1] (lh/setq x 2)))))
(defn render [node]
(case (:op node)
:const (list 'quote (:value node))
:read (:binding node)
:add (list '+ (render (:left node)) (render (:right node)))
:do (list* 'do (map render (:forms node)))
:if (list 'if (render (:test node)) (render (:then node)) (render (:else node)))
:event (list 'com.tailrecursion.blacktide.assignment-test/event! 'events (:tag node) (render (:value node)))
(:setq :psetq) (list* (symbol (name (:op node)))
(mapcat (fn [[name rhs]] [name (render rhs)]) (:writes node)))))
(defn compile-node [node]
;; Preserve known Long producers while reusing code across initial states.
((backend/compile-program
(list 'fn '[x y]
(list 'let ['events '(atom [])]
(list 'loophole '[x (long x) y (long y)]
(list 'let ['result (render node)]
{:value 'result :trace '(deref events)
:vars {(list 'quote 'x) 'x (list 'quote 'y) 'y}})))) :default) nil))
(deftest generated-assignment-programs
;; Compare generated source with the independent interpreter.
(let [property (prop/for-all [node (oracle/expression 3)]
(let [compiled (compile-node node)]
(every? true?
(for [[x y] [[0 0] [1 2] [-7 5] [10 -3]]]
(= (oracle/execute node {'x x 'y y}) (compiled x y))))))]
(doseq [seed [712381 314159]]
(let [result (tc/quick-check 100 property :seed seed)]
(is (:pass? result) (pr-str result))))))
(deftest invocation-arity-boundaries-preserve-operator-and-argument-snapshots
(doseq [n [19 20 21 40]]
(let [args (concat (map #(list 'setq 'x %) (range 1 (inc n))) ['(do (setq f list) x) 'x])
form (list 'loophole '[f vector x 0] [(cons 'f args) '(f :after) 'x])
expected [(vec (concat (range 1 (inc n)) [n n])) '(:after) n]]
(is (= expected (backend/run-form form)) (pr-str {:arity (+ n 2) :form form})))))
(defspec generated-effectful-conditions {:num-tests 100 :seed 20261104}
(prop/for-all [test (gen/elements [(oracle/batch :psetq 'x (oracle/read-var 'y) 'y (oracle/read-var 'x))
(oracle/batch :setq 'x (oracle/lit 0))
(oracle/read-var 'x)])
then (oracle/expression 2) else (oracle/expression 2)]
(let [node {:op :if :test (oracle/event :test test) :then then :else else}
compiled (compile-node node)]
(every? true?
(for [[x y] [[0 0] [1 2] [-7 5] [10 -3]]]
(= (oracle/execute node {'x x 'y y}) (compiled x y)))))))