(ns com.tailrecursion.blacktide.source-test
"Source binding and expansion compared with ordinary Clojure, including
generated lexical programs."
(: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]
[com.tailrecursion.blacktide :as lh :refer [loophole label goto setq psetq]]
[com.tailrecursion.blacktide.source-fixture :as fixture]
[com.tailrecursion.blacktide.backend-fixture :as backend]))
(defn sum [a b] (+ a b))
(defn record! [events tag value] (swap! events conj tag) value)
(defmacro sees-local? [name] (contains? &env name))
(defmacro local-name [name] (list 'quote (:name (get &env name))))
(defmacro nested [expr] `(do (do ~expr)))
(defmacro bind-x [value & body] `(let [~'x ~value] ~@body))
(def expansion-events (atom []))
(defmacro expanded [value] (swap! expansion-events conj value) value)
(def ^:dynamic *operator* identity)
(defn change-operator [x] (set! *operator* (constantly :new)) x)
(defn run-form [form]
(backend/run-form 'com.tailrecursion.blacktide.source-test form))
(defn rejection [form]
(backend/rejection 'com.tailrecursion.blacktide.source-test form))
(deftest sequential-scopes-and-results
(is (nil? (loophole [])))
(is (nil? (loophole [x 1])))
(is (= [1 1 3 4]
(loophole [x 1 y x] (let [x 3 z (sum x y)] (vector y y x z)))))
(is (= [1 2 1]
(loophole [x 1] (vector x (let [x 2] x) x))))
(is (= :done (loophole [] 1 nil :done)))
(is (= 3 (loophole [x 1 x (sum x 2)] x)))
(is (= [3] (loophole [x 3] (-> x vector))))
(is (= '(setq x 3) (loophole [] '(setq x 3))))
(is (= {:op :local :id 'ghost} (loophole [] '{:op :local :id ghost})))
(is (= #'sum (loophole [sum 2] (var sum))))
(is (= String (loophole [] String)))
(let [x 9 f (fn [n] (+ n x))]
(is (= 13 (loophole [] (f 4))))))
(deftest expansion-knows-lexical-context
(is (loophole [x 1] (sees-local? x)))
(is (= 'x (loophole [x 1] (local-name x))))
(is (false? (loophole [] (sees-local? absent))))
(let [caller 1] (is (loophole [] (sees-local? caller))))
(is (= 10 (loophole [x 3] (bind-x 10 (nested x)))))
(is (= [1 2] (loophole [goto vector] (goto 1 2))))
(is (= [3] (loophole [when vector] (when 3))))
(is (= [4] (loophole [loophole vector] (loophole 4))))
(is (= 6 (loophole [] (fixture/goto 6))))
(reset! expansion-events [])
(is (= 3 (run-form '(loophole [x (expanded 1) y (expanded 2)] (expanded 3)))))
(is (= [1 2 3] @expansion-events)))
(deftest macro-visibility-before-expansion
(reset! fixture/expansion-events 0)
(is (thrown-with-msg? IllegalStateException #"not public" (run-form '(fixture/hidden))))
(is (= :private-var (:kind (rejection '(loophole [] (fixture/hidden))))))
(let [v (ns-resolve 'com.tailrecursion.blacktide.source-fixture 'hidden) original (meta v)]
(try
(alter-meta! v assoc :ns (the-ns 'com.tailrecursion.blacktide.source-test))
(is (thrown-with-msg? IllegalStateException #"not public" (run-form '(fixture/hidden))))
(is (= :private-var (:kind (rejection '(loophole [] (fixture/hidden))))))
(finally (reset-meta! v original))))
(is (zero? @fixture/expansion-events))
(binding [*ns* (the-ns 'com.tailrecursion.blacktide.source-fixture)]
(is (= :hidden (eval '(hidden)) (eval '(lh/loophole [] (hidden))))))
(is (= 2 @fixture/expansion-events)))
(deftest source-evaluation-order
(is (= :old
(binding [*operator* (constantly :old)] (*operator* (change-operator 0)))
(binding [*operator* (constantly :old)] (loophole [] (*operator* (change-operator 0))))))
(let [events (atom [])]
(is (= [10 20 30]
(loophole [x (record! events :init 10)]
((do (record! events :operator vector))
(record! events :first x)
(let [x (record! events :second 20)] x)
(record! events :third 30)))))
(is (= [:init :operator :first :second :third] @events)))
(let [events (atom []) error (ex-info "source failure" {})
explode (fn [] (throw error))]
(is (identical? error
(try (loophole [x (record! events :first 1) y (explode)]
(record! events :unreachable x))
(catch Throwable e e))))
(is (= [:first] @events))))
(deftest storage-is-independent-of-redefined-vars
(with-redefs [identity (constantly :changed)]
(is (= 1 (loophole [x 1] x)))
(is (= :changed (loophole [] (identity 2)))))
(doseq [value [nil true false 1 2.5 1N 1M 1/2 \a "text" :key 'name
(byte 1) (short 2) (int 3) (float 4) (Object.)]]
(is (identical? value (loophole [x value] x)))))
(deftest diagnostics-and-public-surface
(is (not (contains? (loaded-libs) 'typed.clojure)))
(is (= '#{loophole label goto setq psetq} (set (keys (ns-publics 'com.tailrecursion.blacktide)))))
(doseq [op '[label goto setq psetq]]
(is (= :outside-region (:kind (rejection (list op))))))
(doseq [[form kind] [['(loophole [x] x) :invalid-bindings]
['(loophole [(x) 1] x) :invalid-binding]
['(loophole [] missing) :unresolved-symbol]
['(loophole [] (quote 1 2)) :invalid-quote]
['(loophole [] (var missing)) :invalid-var]
['(loophole [] (def x 1)) :unsupported-form]
['(loophole [] (reify Object (toString [_] "later"))) :unsupported-form]
['(loophole [x 1] (fn [] x)) :unsupported-form]]]
(is (= kind (:kind (rejection form))) (pr-str form)))
(let [bad (with-meta '(quote 1 2) {:file "example.clj" :line 31 :column 9})
data (rejection (list 'loophole [] bad))]
(is (= {:file "example.clj" :line 31 :column 9 :form bad :kind :invalid-quote}
data))))
(defn expression [depth locals]
(let [leaf (gen/one-of [(gen/choose -15 15) (gen/elements locals)])]
(if (zero? depth) leaf
(let [child (expression (dec depth) locals)]
(gen/one-of
[leaf
(gen/let [a child b child] (list 'sum a b))
;; Regenerate the body in the new scope when the name shrinks.
(gen/let [name (gen/elements '[x y z]) init child
body (expression (dec depth) (conj locals name))]
(list 'let [name init] body))
(gen/let [a child b child] (list 'do a b))
(gen/fmap #(list 'identity %) child)])))))
(defspec deterministic-lexical-programs {:num-tests 150 :seed 20261103}
(prop/for-all [body (expression 3 '[x])]
(let [expected (run-form (list 'let '[x 7] body))]
(every? true?
(for [variant [body (list 'do body) (list 'let ['unused 99] body)]]
(= expected (run-form (list 'loophole '[x 7] variant))))))))
(deftest diagnostic-context-survives-expansion-and-native-boundaries
(doseq [body '[(case)]
prefix [[] ['(goto done)]]]
(let [form (with-meta (list* 'loophole [] (concat prefix [body '(label done)])) {:line 123 :column 9})
error (binding [*file* "diagnostic-example.clj"] (rejection form))]
(is (= :invalid-case (:kind error)))
(is (= '(case) (:form error)))
(is (string? (:file error)))
(is (integer? (:line error)))
(is (integer? (:column error)))))
(let [case (constantly 4)] (is (= 4 (loophole [] (case))))))