rose-ash/lib/datalog/tests/parse.sx

;; lib/datalog/tests/parse.sx — parser unit tests
;;
;; Run via: bash lib/datalog/conformance.sh
;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
;;          (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)

(define dl-pt-pass 0)
(define dl-pt-fail 0)
(define dl-pt-failures (list))

;; Order-independent structural equality. Lists compared positionally,
;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
(define
  dl-deep-equal?
  (fn
    (a b)
    (cond
      ((and (list? a) (list? b))
        (and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
      ((and (dict? a) (dict? b))
        (let
          ((ka (keys a)) (kb (keys b)))
          (and
            (= (len ka) (len kb))
            (dl-deep-equal-dict? a b ka 0))))
      ((and (number? a) (number? b)) (= a b))
      (else (equal? a b)))))

(define
  dl-deep-equal-list?
  (fn
    (a b i)
    (cond
      ((>= i (len a)) true)
      ((not (dl-deep-equal? (nth a i) (nth b i))) false)
      (else (dl-deep-equal-list? a b (+ i 1))))))

(define
  dl-deep-equal-dict?
  (fn
    (a b ka i)
    (cond
      ((>= i (len ka)) true)
      ((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
        false)
      (else (dl-deep-equal-dict? a b ka (+ i 1))))))

(define
  dl-pt-test!
  (fn
    (name got expected)
    (if
      (dl-deep-equal? got expected)
      (set! dl-pt-pass (+ dl-pt-pass 1))
      (do
        (set! dl-pt-fail (+ dl-pt-fail 1))
        (append!
          dl-pt-failures
          (str name "\n    expected: " expected "\n    got:      " got))))))

(define
  dl-pt-throws?
  (fn
    (thunk)
    (let
      ((threw false))
      (do (guard (e (#t (set! threw true))) (thunk)) threw))))

(define
  dl-pt-run-all!
  (fn
    ()
    (do
      (dl-pt-test! "empty program" (dl-parse "") (list))
      (dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
      (dl-pt-test!
        "two facts"
        (dl-parse "parent(tom, bob). parent(bob, ann).")
        (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
      (dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
      (dl-pt-test!
        "rule one body lit"
        (dl-parse "ancestor(X, Y) :- parent(X, Y).")
        (list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
      (dl-pt-test!
        "recursive rule"
        (dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
        (list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
      (dl-pt-test!
        "query single"
        (dl-parse "?- ancestor(tom, X).")
        (list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
      (dl-pt-test!
        "query multi"
        (dl-parse "?- p(X), q(X).")
        (list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
      (dl-pt-test!
        "negation"
        (dl-parse "safe(X) :- person(X), not(parent(X, _)).")
        (list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
      (dl-pt-test!
        "number arg"
        (dl-parse "age(alice, 30).")
        (list {:body (list) :head (list (quote age) (quote alice) 30)}))
      (dl-pt-test!
        "string arg"
        (dl-parse "label(x, \"hi\").")
        (list {:body (list) :head (list (quote label) (quote x) "hi")}))
      (dl-pt-test!
        "comparison literal"
        (dl-parse "p(X) :- <(X, 5).")
        (list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
      (dl-pt-test!
        "is with arith"
        (dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
        (list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
      (dl-pt-test!
        "mixed program"
        (dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
        (list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
      (dl-pt-test!
        "comments skipped"
        (dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
        (list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
      (dl-pt-test!
        "underscore var"
        (dl-parse "p(X) :- q(X, _).")
        (list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
      (dl-pt-test!
        "missing dot raises"
        (dl-pt-throws? (fn () (dl-parse "p(a)")))
        true)
      (dl-pt-test!
        "trailing comma raises"
        (dl-pt-throws? (fn () (dl-parse "p(a,).")))
        true))))

(define
  dl-parse-tests-run!
  (fn
    ()
    (do
      (set! dl-pt-pass 0)
      (set! dl-pt-fail 0)
      (set! dl-pt-failures (list))
      (dl-pt-run-all!)
      {:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))