rose-ash/lib/relations/tests/direct.sx

;; lib/relations/tests/direct.sx — Phase 1: schema + direct relations.

(define relations-dt-pass 0)
(define relations-dt-fail 0)
(define relations-dt-failures (list))

(define
  relations-dt-check!
  (fn
    (name got expected)
    (if
      (= got expected)
      (set! relations-dt-pass (+ relations-dt-pass 1))
      (do
        (set! relations-dt-fail (+ relations-dt-fail 1))
        (append!
          relations-dt-failures
          (str name "\n    expected: " expected "\n    got:      " got))))))

;; Order-insensitive membership: every x in xs is in ys.
(define
  relations-dt-subset?
  (fn
    (xs ys)
    (cond
      ((= (len xs) 0) true)
      ((relations-member? (first xs) ys)
        (relations-dt-subset? (rest xs) ys))
      (else false))))

(define
  relations-dt-set=?
  (fn
    (xs ys)
    (and
      (= (len xs) (len ys))
      (relations-dt-subset? xs ys)
      (relations-dt-subset? ys xs))))

;; Fixture: a small forest with two kinds.
;;   parent: a -> b, a -> c, b -> d
;;   reply:  p -> q
(define
  relations-dt-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote a) (quote b) (quote parent))
        (relations-rel (quote a) (quote c) (quote parent))
        (relations-rel (quote b) (quote d) (quote parent))
        (relations-rel (quote p) (quote q) (quote reply))))))

(define
  relations-dt-run-all!
  (fn
    ()
    (let
      ((db (relations-dt-fixture)))
      (do
        (relations-dt-check!
          "direct children of a"
          (relations-dt-set=?
            (relations-children-of db (quote a) (quote parent))
            (list (quote b) (quote c)))
          true)
        (relations-dt-check!
          "direct children of b"
          (relations-dt-set=?
            (relations-children-of db (quote b) (quote parent))
            (list (quote d)))
          true)
        (relations-dt-check!
          "leaf has no children"
          (relations-children-of db (quote d) (quote parent))
          (list))
        (relations-dt-check!
          "direct parents of b"
          (relations-dt-set=?
            (relations-parents-of db (quote b) (quote parent))
            (list (quote a)))
          true)
        (relations-dt-check!
          "root has no parents"
          (relations-parents-of db (quote a) (quote parent))
          (list))
        (relations-dt-check!
          "related is both directions"
          (relations-dt-set=?
            (relations-related db (quote b) (quote parent))
            (list (quote d) (quote a)))
          true)
        (relations-dt-check!
          "kind isolation: parent query skips reply edge"
          (relations-children-of db (quote p) (quote parent))
          (list))
        (relations-dt-check!
          "reply children of p"
          (relations-dt-set=?
            (relations-children-of db (quote p) (quote reply))
            (list (quote q)))
          true)
        (relations-dt-check!
          "unknown node -> empty"
          (relations-children-of db (quote zzz) (quote parent))
          (list))
        (let
          ((db2 (relations-build-db (list (relations-rel (quote x) (quote y) (quote parent))))))
          (do
            (relations-dt-check!
              "before retract: y is a child of x"
              (relations-dt-set=?
                (relations-children-of db2 (quote x) (quote parent))
                (list (quote y)))
              true)
            (dl-retract!
              db2
              (relations-rel (quote x) (quote y) (quote parent)))
            (relations-dt-check!
              "after retract: x has no children"
              (relations-children-of db2 (quote x) (quote parent))
              (list))))
        (do
          (relations/load! (list))
          (relations/relate (quote o1) (quote li1) (quote member))
          (relations/relate (quote o1) (quote li2) (quote member))
          (relations-dt-check!
            "api relate then children"
            (relations-dt-set=?
              (relations/children (quote o1) (quote member))
              (list (quote li1) (quote li2)))
            true)
          (relations-dt-check!
            "api parents"
            (relations-dt-set=?
              (relations/parents (quote li1) (quote member))
              (list (quote o1)))
            true)
          (relations/unrelate (quote o1) (quote li1) (quote member))
          (relations-dt-check!
            "api unrelate removes one child"
            (relations-dt-set=?
              (relations/children (quote o1) (quote member))
              (list (quote li2)))
            true)
          (relations/load! (list))
          (relations-dt-check!
            "api reload clears prior facts"
            (relations/children (quote o1) (quote member))
            (list)))
        (relations-dt-check!
          "rel constructor shape"
          (relations-rel (quote s) (quote d) (quote parent))
          (list (quote rel) (quote s) (quote d) (quote parent)))
        (relations-dt-check!
          "fact valid"
          (relations-fact-valid?
            (relations-rel (quote s) (quote d) (quote parent)))
          true)
        (relations-dt-check!
          "fact bad arity invalid"
          (relations-fact-valid? (list (quote rel) (quote s)))
          false)
        (relations-dt-check!
          "fact wrong head invalid"
          (relations-fact-valid?
            (list (quote edge) (quote s) (quote d) (quote parent)))
          false)
        (relations-dt-check!
          "known kind"
          (relations-known-kind? (quote parent))
          true)
        (relations-dt-check!
          "unknown kind"
          (relations-known-kind? (quote frobnicate))
          false)
        (relations-dt-check!
          "accessors"
          (list
            (relations-rel-src
              (relations-rel (quote s) (quote d) (quote k)))
            (relations-rel-dst
              (relations-rel (quote s) (quote d) (quote k)))
            (relations-rel-kind
              (relations-rel (quote s) (quote d) (quote k))))
          (list (quote s) (quote d) (quote k)))))))

(define
  relations-direct-tests-run!
  (fn
    ()
    (do
      (set! relations-dt-pass 0)
      (set! relations-dt-fail 0)
      (set! relations-dt-failures (list))
      (relations-dt-run-all!)
      {:failures relations-dt-failures :total (+ relations-dt-pass relations-dt-fail) :passed relations-dt-pass :failed relations-dt-fail})))