datahike-browser-tests 1.0.0

package/test/datahike/test/model/core.cljc

@@ -0,0 +1,376 @@
+(ns datahike.test.model.core
+  "Pure model of Datahike semantics for model-based testing.
+   
+   This namespace implements a pure Clojure model of how Datahike
+   should behave, without any side effects. It can be used to:
+   
+   1. Generate valid sequences of transactions
+   2. Track expected state after each transaction
+   3. Compare expected state against actual Datahike state
+   
+   The model handles:
+   - Cardinality semantics (one vs many)
+   - Type constraints (string, long, ref)
+   - Historical state tracking (for as-of queries)
+   - Index content tracking (EAVT, AVET, AEVT)"
+  (:require [datahike.test.model.rng :as rng]))
+
+;; =============================================================================
+;; Pattern Matching (for remove-by-pattern)
+;; =============================================================================
+
+(defn- matches
+  "Helper that treats nil as wildcard."
+  [x0 x]
+  (or (nil? x0) (= x0 x)))
+
+(defn predicate-from-pattern
+  "Returns a predicate function for a pattern.
+   Nil in any position matches anything."
+  [[e0 a0 v0]]
+  (fn [[e a v]]
+    (and (matches e0 e)
+         (matches a0 a)
+         (matches v0 v))))
+
+(defn remove-pattern
+  "Filter a set of datoms by removing those matching pattern."
+  [datom-set pattern]
+  (into #{} (remove (predicate-from-pattern pattern)) datom-set))
+
+;; =============================================================================
+;; Model State
+;; =============================================================================
+
+(defrecord Model
+           [;; Schema: {attr-ident {:db/valueType, :db/cardinality, :db/index, ...}}
+            schema
+            ;; Current datoms: #{[e a v]}
+            current-datoms
+            ;; Historical states: {tx #{[e a v]}}
+            ;; Maps transaction ID to state at that transaction
+            history
+            ;; Transaction counter
+            next-tx])
+
+(defn create-model
+  "Create initial model state with given schema."
+  [schema]
+  (->Model schema #{} {} 536870912))
+
+;; =============================================================================
+;; Core Semantics: Accumulate Datom
+;; =============================================================================
+
+(defn lookup-attribute
+  "Look up attribute info from schema."
+  [schema a]
+  (or (get schema a)
+      (throw (ex-info (str "Attribute not found: " a) {:attribute a}))))
+
+(defn accumulate-datom
+  "Apply a single datom to the model state.
+   
+   This is the core of the model - it implements Datahike's
+   cardinality semantics in pure Clojure:
+   
+   - :db.cardinality/one: Replaces existing value for [e a]
+   - :db.cardinality/many: Accumulates values, no duplicates
+   
+   Returns updated datom set."
+  [schema datom-set [e a v added]]
+  (if added
+    (let [attr (lookup-attribute schema a)
+          cardinality (or (:db/cardinality attr) :db.cardinality/one)]
+      (case cardinality
+        :db.cardinality/many
+        (if (some (predicate-from-pattern [e a v]) datom-set)
+          datom-set
+          (conj datom-set [e a v]))
+        :db.cardinality/one
+        (-> datom-set
+            (remove-pattern [e a nil])
+            (conj [e a v]))))
+    (remove-pattern datom-set [e a v])))
+
+(defn apply-tx
+  "Apply a transaction to the model, returning updated model.
+   
+   Transaction format: {:tx-data [[op e a v] ...]}
+   where op is :db/add or :db/retract.
+   
+   Also records historical state for as-of queries."
+  [model {:keys [tx-data] :as _tx}]
+  (let [tx-id (:next-tx model)
+        ;; For accumulate-datom, we need [e a v added] (4 elements)
+        datoms-for-accumulate (mapv (fn [[op e a v]]
+                                      [e a v (= op :db/add)])
+                                    tx-data)
+        new-current (reduce
+                     (fn [acc datom]
+                       (accumulate-datom (:schema model) acc datom))
+                     (:current-datoms model)
+                     datoms-for-accumulate)
+        new-history (assoc (:history model) tx-id new-current)]
+    (assoc model
+           :current-datoms new-current
+           :history new-history
+           :next-tx (inc tx-id))))
+
+(defn apply-txs
+  "Apply multiple transactions sequentially."
+  [model txs]
+  (reduce apply-tx model txs))
+
+;; =============================================================================
+;; Querying the Model
+;; =============================================================================
+
+(defn get-current-datoms
+  "Get current datoms as a set of [e a v] tuples."
+  [model]
+  (:current-datoms model))
+
+(defn get-datoms-at-tx
+  "Get datoms as of a specific transaction."
+  [model tx-id]
+  (get (:history model) tx-id))
+
+(defn get-transaction-ids
+  "Get all transaction IDs in order."
+  [model]
+  (sort (keys (:history model))))
+
+;; =============================================================================
+;; Index Computation
+;; =============================================================================
+
+(defn compute-eavt
+  "Compute EAVT index from model (sorted by [e a v])."
+  [model]
+  (sort-by identity (get-current-datoms model)))
+
+(defn compute-aevt
+  "Compute AEVT index from model (sorted by [a e v])."
+  [model]
+  (sort-by (fn [[e a v]] [a e v]) (get-current-datoms model)))
+
+(defn indexed-attrs
+  "Get set of indexed attribute identifiers from schema."
+  [schema]
+  (set (keep (fn [[k v]] (when (:db/index v) k)) schema)))
+
+(defn ref-attrs
+  "Get set of ref-type attribute identifiers from schema."
+  [schema]
+  (set (keep (fn [[k v]] (when (= :db.type/ref (:db/valueType v)) k)) schema)))
+
+(defn compute-avet
+  "Compute AVET index from model.
+   
+   Only includes datoms where:
+   - Attribute has :db/index true, OR
+   - Attribute is :db.type/ref"
+  [model]
+  (let [schema (:schema model)
+        indexed (indexed-attrs schema)
+        refs (ref-attrs schema)
+        indexed-or-ref? (fn [a]
+                          (or (contains? indexed a)
+                              (contains? refs a)))]
+    (sort-by (fn [[e a v]] [a v e])
+             (filter (fn [[_e a _v]] (indexed-or-ref? a))
+                     (get-current-datoms model)))))
+
+;; =============================================================================
+;; Transaction Generation - Weighted Action Sampling
+;; =============================================================================
+
+(def action-weights
+  "Weights for each action type in transaction generation.
+   :add      - Add entirely new random datom
+   :remove   - Retract an existing datom
+   :tweak    - Take existing datom, generate new value for same entity/attribute
+   :combine  - Take two existing datoms, mix their entity/value parts
+   :transact - End current transaction (emit boundary)"
+  {:add 4
+   :remove 2
+   :tweak 1
+   :combine 1
+   :transact 1})
+
+(defn- generate-value
+  "Generate a random value for the given attribute type."
+  [rng value-type entity-range]
+  (case value-type
+    :db.type/string (str "v" (rng/next-int rng 100))
+    :db.type/long (long (rng/next-int rng 100))
+    :db.type/ref (rng/rand-nth-rng rng entity-range)
+    :db.type/boolean (rng/next-boolean rng)
+    :db.type/keyword (keyword (str "k" (rng/next-int rng 20)))
+    (rng/next-long rng)))
+
+(defn- generate-add
+  "Generate a random :db/add operation."
+  [rng schema entity-range]
+  (let [attr-idents (vec (keys schema))
+        attr-id (rng/rand-nth-rng rng attr-idents)
+        attr (get schema attr-id)
+        value-type (:db/valueType attr)
+        e (rng/rand-nth-rng rng entity-range)
+        v (generate-value rng value-type entity-range)]
+    [:db/add e attr-id v]))
+
+(defn- generate-remove
+  "Generate a :db/retract operation from existing datoms."
+  [rng current-datoms]
+  (let [[e a v] (rng/rand-nth-rng rng (vec current-datoms))]
+    [:db/retract e a v]))
+
+(defn- generate-tweak
+  "Generate a :db/add that modifies an existing datom with a new value.
+   Exercises cardinality-one replacement and upsert semantics."
+  [rng schema entity-range current-datoms]
+  (let [[e a _old-v] (rng/rand-nth-rng rng (vec current-datoms))
+        attr (get schema a)
+        value-type (:db/valueType attr)
+        new-v (generate-value rng value-type entity-range)]
+    [:db/add e a new-v]))
+
+(defn- generate-combine
+  "Generate a :db/add by mixing entity or value from two datoms with same attribute.
+   Creates interesting patterns while preserving type safety.
+   Returns nil if no valid combination exists."
+  [rng current-datoms]
+  (when (seq current-datoms)
+    (let [by-attr (group-by second current-datoms)
+          valid-groups (filter #(<= 2 (count (second %))) by-attr)]
+      (when (seq valid-groups)
+        (let [[_ datoms-with-same-attr] (rng/rand-nth-rng rng (vec valid-groups))
+              [e1 a _v1] (rng/rand-nth-rng rng (vec datoms-with-same-attr))
+              [e2 _a v2] (rng/rand-nth-rng rng (vec datoms-with-same-attr))
+              idx (rng/next-int rng 2)
+              e (case idx 0 e1 1 e2)
+              v (case idx 0 v2 1 v2)]
+          [:db/add e a v])))))
+
+(defn- sample-action
+  "Sample an action type based on weights and current state.
+   When no datoms exist, only :add or :transact are valid."
+  [rng current-datoms]
+  (if (seq current-datoms)
+    (rng/weighted-sample-rng rng action-weights)
+    (rng/weighted-sample-rng rng {:add 4 :transact 1})))
+
+(defn- datom-equivalence
+  "Returns the equivalence key for a datom.
+   Two datoms are equivalent if they would conflict in the same transaction.
+   For cardinality-one: same [e a]
+   For cardinality-many: same [e a v]"
+  [schema [e a v]]
+  (let [attr (get schema a)
+        cardinality (or (:db/cardinality attr) :db.cardinality/one)]
+    (case cardinality
+      :db.cardinality/many [e a v]
+      :db.cardinality/one [e a])))
+
+(defn- op-equivalence
+  "Returns the equivalence key for an operation [op e a v].
+   Ignores the op type - add and retract of same datom are equivalent."
+  [schema [_op e a v]]
+  (datom-equivalence schema [e a v]))
+
+(defn generate-transaction
+  "Generate a single transaction using weighted action sampling.
+   
+   Returns tx-ops: a vector of [op e a v] operations.
+   
+   The transaction ends when:
+   - :transact action is sampled (probabilistic boundary)
+   - max-ops limit is reached
+   
+   Uses an internal datom set to track state during generation, so operations
+   can reference datoms from previous operations within the same transaction.
+   Does NOT update model state - caller should apply the transaction.
+   
+   Avoids generating conflicting operations within the same transaction
+   (e.g., add and retract of same datom, or two adds of same cardinality-one
+   attribute with same entity but different values)."
+  [rng schema entity-range model-state max-ops]
+  (let [initial-datoms (get-current-datoms model-state)]
+    (letfn [(accumulate [datoms [e a v added?]]
+              (if added?
+                (let [attr (lookup-attribute schema a)
+                      cardinality (or (:db/cardinality attr) :db.cardinality/one)]
+                  (case cardinality
+                    :db.cardinality/many
+                    (if (some (predicate-from-pattern [e a v]) datoms)
+                      datoms
+                      (conj datoms [e a v]))
+                    :db.cardinality/one
+                    (-> datoms
+                        (remove-pattern [e a nil])
+                        (conj [e a v]))))
+                (remove-pattern datoms [e a v])))
+
+            (apply-op-to-datoms [datoms [op e a v]]
+              (accumulate datoms [e a v (= op :db/add)]))
+
+            (equiv-key [op]
+              (op-equivalence schema op))
+
+            (step [ops current-datoms current-equiv n]
+              (if (>= n max-ops)
+                (vec ops)
+                (let [action (sample-action rng current-datoms)]
+                  (case action
+                    :transact
+                    (vec ops)
+
+                    :add
+                    (let [op (generate-add rng schema entity-range)
+                          equiv (equiv-key op)]
+                      (if (contains? current-equiv equiv)
+                        ;; Skip conflicting op, try again with same n
+                        (recur ops current-datoms current-equiv n)
+                        ;; Accept op
+                        (let [current-datoms' (apply-op-to-datoms current-datoms op)]
+                          (recur (conj ops op) current-datoms' (conj current-equiv equiv) (inc n)))))
+
+                    :remove
+                    (let [op (generate-remove rng current-datoms)
+                          equiv (equiv-key op)]
+                      (if (contains? current-equiv equiv)
+                        (recur ops current-datoms current-equiv n)
+                        (let [current-datoms' (apply-op-to-datoms current-datoms op)]
+                          (recur (conj ops op) current-datoms' (conj current-equiv equiv) (inc n)))))
+
+                    :tweak
+                    (let [op (generate-tweak rng schema entity-range current-datoms)
+                          equiv (equiv-key op)]
+                      (if (contains? current-equiv equiv)
+                        (recur ops current-datoms current-equiv n)
+                        (let [current-datoms' (apply-op-to-datoms current-datoms op)]
+                          (recur (conj ops op) current-datoms' (conj current-equiv equiv) (inc n)))))
+
+                    :combine
+                    (if-let [op (generate-combine rng current-datoms)]
+                      (let [equiv (equiv-key op)]
+                        (if (contains? current-equiv equiv)
+                          (recur ops current-datoms current-equiv n)
+                          (let [current-datoms' (apply-op-to-datoms current-datoms op)]
+                            (recur (conj ops op) current-datoms' (conj current-equiv equiv) (inc n)))))
+                      ;; combine failed, skip this iteration
+                      (recur ops current-datoms current-equiv (inc n)))))))]
+      (step [] initial-datoms #{} 0))))
+
+(defn generate-tx-batch
+  "Generate a batch of transaction operations.
+   
+   Deprecated: Use generate-transaction for weighted action sampling.
+   Kept for backward compatibility."
+  ([rng schema entity-range max-ops]
+   (generate-tx-batch rng schema entity-range max-ops nil))
+  ([rng schema entity-range max-ops model-state]
+   (let [n (inc (rng/next-int rng max-ops))]
+     (vec (repeatedly n #(generate-add rng schema entity-range))))))

package/test/datahike/test/model/invariant.cljc

@@ -0,0 +1,142 @@
+(ns datahike.test.model.invariant
+  "Invariant checking framework for datahike model-based testing."
+  (:require [clojure.set :as set]
+            [datahike.api :as d]
+            [datahike.datom :as dd]
+            [datahike.db.interface :as dbi]
+            [datahike.test.model.core :as model]))
+
+(defprotocol PInvariant
+  (check [this model-state actual-db])
+  (invariant-name [_this]))
+
+(defn check-all
+  "Check all invariants against model and actual DB."
+  [invariants model-state actual-db]
+  (let [violations (keep #(check % model-state actual-db) invariants)]
+    (if (empty? violations)
+      {:valid? true}
+      {:valid? false :violations (vec violations)})))
+
+;; =============================================================================
+;; Helper Functions
+;; =============================================================================
+
+(defn- eav-triplet-set
+  "Convert datoms to a set of [e a v] tuples, filtering to user-attrs.
+   
+   Handles both :attribute-refs? true and false:
+   - When true, :a is entity ID, uses dbi/-ident-for to convert
+   - When false, :a is already a keyword ident"
+  [db user-attrs datoms]
+  (let [attr-refs? (:attribute-refs? (.-config db))]
+    (into #{}
+          (comp (filter (if attr-refs?
+                          (comp user-attrs #(dbi/-ident-for db %) :a)
+                          (comp user-attrs :a)))
+                (map (if attr-refs?
+                       (juxt :e #(dbi/-ident-for db (:a %)) :v)
+                       (juxt :e :a :v))))
+          datoms)))
+
+;; =============================================================================
+;; Index Sortedness Invariant
+;; =============================================================================
+
+(defrecord IndexSortedInvariant [index-type]
+  PInvariant
+  (check [_this _model-state actual-db]
+    (let [actual-datoms (into [] (d/datoms actual-db index-type))
+          cmp-fn (dd/index-type->cmp-quick index-type true)
+          pairs (partition 2 1 actual-datoms)]
+      (when-not (every?
+                 (fn [[a b]] (not (pos? (cmp-fn a b))))
+                 pairs)
+        {:violation :index-unsorted
+         :evidence {:index-type index-type
+                    :sample (take 10 actual-datoms)}})))
+  (invariant-name [_this]
+    (str (name index-type) "-sorted")))
+
+;; =============================================================================
+;; Index Content Invariant
+;; =============================================================================
+
+(defrecord IndexContentInvariant [index-type user-attrs]
+  PInvariant
+  (check [_this model-state actual-db]
+    (let [actual-datoms (eav-triplet-set actual-db user-attrs (d/datoms actual-db index-type))
+          expected-datoms (case index-type
+                            :eavt (set (model/compute-eavt model-state))
+                            :aevt (set (model/compute-aevt model-state))
+                            :avet (set (model/compute-avet model-state))
+                            (throw (ex-info "Unknown index" {:index-type index-type})))
+          missing (set/difference expected-datoms actual-datoms)
+          extra (set/difference actual-datoms expected-datoms)]
+      (when (or (seq missing) (seq extra))
+        {:violation :index-content-mismatch
+         :evidence {:index-type index-type
+                    :missing (vec (take 10 missing))
+                    :extra (vec (take 10 extra))}})))
+  (invariant-name [_this]
+    (str (name index-type) "-content")))
+
+;; =============================================================================
+;; Historical Consistency Invariant
+;; =============================================================================
+
+(defrecord HistoricalConsistencyInvariant [actual-tx-ids tx-offset user-attrs]
+  PInvariant
+  (check [_this model-state actual-db]
+    (let [violations
+          (for [actual-tx actual-tx-ids
+                :let [model-tx (- actual-tx tx-offset)
+                      expected (model/get-datoms-at-tx model-state model-tx)
+                      actual (try
+                               (eav-triplet-set (d/as-of actual-db actual-tx) user-attrs (d/datoms (d/as-of actual-db actual-tx) :eavt))
+                               (catch Exception _ nil))
+                      missing (when actual (set/difference expected actual))
+                      extra (when actual (set/difference actual expected))]
+                :when (and actual (or (seq missing) (seq extra)))]
+            {:tx-id actual-tx
+             :model-tx model-tx
+             :missing (vec (take 5 missing))
+             :extra (vec (take 5 extra))})]
+      (when (seq violations)
+        {:violation :historical-mismatch
+         :evidence {:violations (vec violations)}})))
+  (invariant-name [_this]
+    "historical-consistency"))
+
+;; =============================================================================
+;; Constructor Functions
+;; =============================================================================
+
+(defn index-sorted
+  "Create invariant that checks an index is sorted."
+  [index-type]
+  (->IndexSortedInvariant index-type))
+
+(defn index-content
+  "Create invariant that checks index content matches model."
+  [index-type user-attrs]
+  (->IndexContentInvariant index-type user-attrs))
+
+(defn historical-consistency
+  "Create invariant that checks historical states match as-of queries.
+   
+   actual-tx-ids: the actual transaction IDs in Datahike
+   tx-offset: the offset to convert actual tx-ids to model tx-ids
+   user-attrs: the set of user attributes to check"
+  [actual-tx-ids tx-offset user-attrs]
+  (->HistoricalConsistencyInvariant actual-tx-ids tx-offset user-attrs))
+
+(defn all-index-invariants
+  "Create all standard index invariants (sortedness + content for EAVT, AVET, AEVT)."
+  [user-attrs]
+  [(index-sorted :eavt)
+   (index-sorted :avet)
+   (index-sorted :aevt)
+   (index-content :eavt user-attrs)
+   (index-content :avet user-attrs)
+   (index-content :aevt user-attrs)])

package/test/datahike/test/model/rng.cljc

@@ -0,0 +1,82 @@
+(ns datahike.test.model.rng
+  "Fork-safe random number generation using SplittableRandom."
+  #?(:clj (:import [java.util SplittableRandom])))
+
+(defprotocol PRNG
+  (next-double [this])
+  (next-long [this])
+  (next-int [this bound])
+  (next-boolean [this])
+  (fork [this]))
+
+#?(:clj
+   (defn- wrap-splittable-random
+     [rng]
+     (reify PRNG
+       (next-double [_] (.nextDouble rng))
+       (next-long [_] (.nextLong rng))
+       (next-int [_ bound] (.nextInt rng (int bound)))
+       (next-boolean [_] (.nextBoolean rng))
+       (fork [_] (wrap-splittable-random (.split rng))))))
+
+#?(:clj
+   (defn create
+     [seed]
+     (wrap-splittable-random (SplittableRandom. (long seed)))))
+
+#?(:cljs
+   (defn- step-state
+     "Linear congruential generator step function."
+     [s]
+     (mod (+ (* s 1103515245) 12345) (js/Math.pow 2 31))))
+
+#?(:cljs
+   (defn create
+     [seed]
+     (let [state (atom (long seed))]
+       (reify PRNG
+         (next-double [_]
+           (/ (double (swap! state step-state)) (js/Math.pow 2 31)))
+         (next-long [_]
+           (swap! state step-state))
+         (next-int [_ bound]
+           (mod (swap! state step-state) bound))
+         (next-boolean [_]
+           (even? (swap! state step-state)))
+         (fork [_]
+           (create (swap! state step-state)))))))
+
+(defn should-trigger?
+  [rng rate]
+  (< (next-double rng) rate))
+
+(defn random-in-range
+  [rng min-val max-val]
+  (+ min-val (next-int rng (inc (- max-val min-val)))))
+
+(defn rand-nth-rng
+  [rng coll]
+  (nth coll (next-int rng (count coll))))
+
+(defn weighted-sample-rng
+  [rng pairs]
+  (let [sum (transduce (map second) + pairs)
+        at (* sum (next-double rng))]
+    (loop [at at
+           [[k w] & rest] pairs]
+      (if (<= at w)
+        k
+        (recur (- at w) rest)))))
+
+(defn shuffle-rng
+  [rng coll]
+  (let [v (vec coll)
+        n (count v)]
+    (loop [i (dec n)
+           v v]
+      (if (pos? i)
+        (let [j (next-int rng (inc i))
+              vi (v i)
+              vj (v j)]
+          (recur (dec i) (assoc v i vj j vi)))
+        v))))