giles
5a1dc4392f
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
(p X _), (p _ Y) — the two _ are now different variables, matching standard Datalog semantics. Previously both _ symbols were the same SX symbol, so unification across them gave wrong answers. Fix in db.sx: dl-rename-anon-term + dl-rename-anon-lit walk a term or literal and replace each '_' symbol with a fresh _anon<N>. dl-make-anon-renamer returns a counter-based name generator scoped per call. dl-rename-anon-rule applies it to head and body of a rule. dl-add-rule! invokes the renamer before safety check. eval.sx: dl-query renames anon vars in the goal before search and filters '_' out of the projection so user-facing results aren't polluted with internal _anon<N> bindings. The previous "underscore in head ok" test now correctly rejects (p X _) :- q(X) as unsafe (the head's fresh anon var has no body binder). New "underscore in body only" test confirms the safe case. Two regression tests for rule-level and goal-level independence.
230 lines
7.2 KiB
Plaintext
230 lines
7.2 KiB
Plaintext
;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
|
|
|
|
(define dl-et-pass 0)
|
|
(define dl-et-fail 0)
|
|
(define dl-et-failures (list))
|
|
|
|
;; Same deep-equal helper used in other suites.
|
|
(define
|
|
dl-et-deep=?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (list? a) (list? b))
|
|
(and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
|
|
((and (dict? a) (dict? b))
|
|
(let
|
|
((ka (keys a)) (kb (keys b)))
|
|
(and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
|
|
((and (number? a) (number? b)) (= a b))
|
|
(else (equal? a b)))))
|
|
|
|
(define
|
|
dl-et-deq-l?
|
|
(fn
|
|
(a b i)
|
|
(cond
|
|
((>= i (len a)) true)
|
|
((not (dl-et-deep=? (nth a i) (nth b i))) false)
|
|
(else (dl-et-deq-l? a b (+ i 1))))))
|
|
|
|
(define
|
|
dl-et-deq-d?
|
|
(fn
|
|
(a b ka i)
|
|
(cond
|
|
((>= i (len ka)) true)
|
|
((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
|
|
false)
|
|
(else (dl-et-deq-d? a b ka (+ i 1))))))
|
|
|
|
;; Set-equality on lists (order-independent, uses dl-et-deep=?).
|
|
(define
|
|
dl-et-set=?
|
|
(fn
|
|
(a b)
|
|
(and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
|
|
|
|
(define
|
|
dl-et-subset?
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((= (len xs) 0) true)
|
|
((not (dl-et-contains? ys (first xs))) false)
|
|
(else (dl-et-subset? (rest xs) ys)))))
|
|
|
|
(define
|
|
dl-et-contains?
|
|
(fn
|
|
(xs target)
|
|
(cond
|
|
((= (len xs) 0) false)
|
|
((dl-et-deep=? (first xs) target) true)
|
|
(else (dl-et-contains? (rest xs) target)))))
|
|
|
|
(define
|
|
dl-et-test!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-et-deep=? got expected)
|
|
(set! dl-et-pass (+ dl-et-pass 1))
|
|
(do
|
|
(set! dl-et-fail (+ dl-et-fail 1))
|
|
(append!
|
|
dl-et-failures
|
|
(str name "\n expected: " expected "\n got: " got))))))
|
|
|
|
(define
|
|
dl-et-test-set!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-et-set=? got expected)
|
|
(set! dl-et-pass (+ dl-et-pass 1))
|
|
(do
|
|
(set! dl-et-fail (+ dl-et-fail 1))
|
|
(append!
|
|
dl-et-failures
|
|
(str
|
|
name
|
|
"\n expected (set): "
|
|
expected
|
|
"\n got: "
|
|
got))))))
|
|
|
|
(define
|
|
dl-et-throws?
|
|
(fn
|
|
(thunk)
|
|
(let
|
|
((threw false))
|
|
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
|
|
|
(define
|
|
dl-et-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
(dl-et-test-set!
|
|
"fact lookup any"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob). parent(bob, ann).")
|
|
(list (quote parent) (quote X) (quote Y)))
|
|
(list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
|
|
(dl-et-test-set!
|
|
"fact lookup constant arg"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
|
|
(list (quote parent) (quote tom) (quote Y)))
|
|
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
(dl-et-test-set!
|
|
"no match"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob).")
|
|
(list (quote parent) (quote nobody) (quote X)))
|
|
(list))
|
|
(dl-et-test-set!
|
|
"ancestor closure"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(bob, ann). parent(ann, pat).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
|
(list (quote ancestor) (quote tom) (quote X)))
|
|
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
|
(dl-et-test-set!
|
|
"sibling"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n sibling(X, Y) :- parent(P, X), parent(P, Y).")
|
|
(list (quote sibling) (quote bob) (quote Y)))
|
|
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
(dl-et-test-set!
|
|
"same-generation"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n person(tom). person(bob). person(liz). person(ann). person(joe).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
|
|
(list (quote sg) (quote ann) (quote X)))
|
|
(list {:X (quote ann)} {:X (quote joe)}))
|
|
(dl-et-test!
|
|
"ancestor count"
|
|
(let
|
|
((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
|
6)
|
|
(dl-et-test-set!
|
|
"grandparent"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(a, b). parent(b, c). parent(c, d).\n grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
|
|
(list (quote grandparent) (quote X) (quote Y)))
|
|
(list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
|
|
(dl-et-test!
|
|
"no recursion infinite loop"
|
|
(let
|
|
((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
|
|
(do (dl-saturate! db) (len (dl-relation db "reach"))))
|
|
9)
|
|
(dl-et-test!
|
|
"unsafe head var"
|
|
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
|
|
true)
|
|
(dl-et-test!
|
|
"unsafe — empty body"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- .")))
|
|
true)
|
|
;; Underscore in head is unsafe — it's a fresh existential per
|
|
;; occurrence after Phase 5d's anonymous-var renaming, and there's
|
|
;; nothing in the body to bind it. (Old behavior accepted this by
|
|
;; treating '_' as a literal name to skip; the renaming made it an
|
|
;; ordinary unbound variable.)
|
|
(dl-et-test!
|
|
"underscore in head — unsafe"
|
|
(dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
|
|
true)
|
|
(dl-et-test!
|
|
"underscore in body only — safe"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
|
|
false)
|
|
(dl-et-test!
|
|
"var only in head — unsafe"
|
|
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
|
|
true)
|
|
(dl-et-test!
|
|
"head var bound by body"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
|
|
false)
|
|
(dl-et-test!
|
|
"head subset of body"
|
|
(dl-et-throws?
|
|
(fn
|
|
()
|
|
(dl-program
|
|
"edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
|
|
false)
|
|
|
|
;; Anonymous variables: each occurrence must be independent.
|
|
(dl-et-test-set! "anon vars in rule are independent"
|
|
(dl-query
|
|
(dl-program
|
|
"p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
|
|
(list (quote q) (quote X)))
|
|
(list {:X (quote a)} {:X (quote c)}))
|
|
|
|
(dl-et-test-set! "anon vars in goal are independent"
|
|
(dl-query
|
|
(dl-program "p(1, 2, 3). p(4, 5, 6).")
|
|
(list (quote p) (quote _) (quote X) (quote _)))
|
|
(list {:X 2} {:X 5})))))
|
|
|
|
(define
|
|
dl-eval-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! dl-et-pass 0)
|
|
(set! dl-et-fail 0)
|
|
(set! dl-et-failures (list))
|
|
(dl-et-run-all!)
|
|
{:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))
|