pyrites/haskell-experiments/test/Test/Datalog/InMemoryDBSpec.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# HLINT ignore "Use const" #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# HLINT ignore "Avoid lambda" #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Test.Datalog.InMemoryDBSpec where

import Data.Map qualified as Map
import Data.Set qualified as Set
import Datalog.DatalogParser
import Datalog.InMemoryDB
import Datalog.InMemoryDB qualified as InMemoryDB
import Test.Hspec
import Datalog.DatalogDB
import Data.Text

spec :: Spec
spec = do
  describe "InMemoryDB operations" do
    it "can ingest facts into relations & a universe" $ do
      let db =
            InMemoryDB.withFacts
              [ "parent(\"alice\", \"bob\")."
              , "parent(\"bob\", \"carol\")."
              ]
      constants db
        `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
      relations db
        `shouldBe` Map.fromList
          [
            ( "parent"
            , Relation "parent" 2 (Set.fromList $ Sym <<$>> [["alice", "bob"], ["bob", "carol"]]) []
            )
          ]
    it "can ingest facts and rules" do
      let db =
            InMemoryDB.withFactsAndRules
              [ "parent(\"alice\", \"bob\")."
              , "parent(\"bob\", \"carol\")."
              ]
              [ "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
              , "ancestor(X,Y) :- parent(X,Y)."
              ]
          parentRelation =
            Relation
              { _name = "parent"
              , _arity = 2
              , _tuples =
                  Set.fromList $
                    Sym <<$>> [["alice", "bob"], ["bob", "carol"]]
              , _rules = []
              }
          ancestorRule = RelationRule
              { headVariables = ["X", "Y", "Z"]
              , bodyElements =
                  [ ruleBody "parent"   [0, 2]
                  , ruleBody "ancestor" [2, 1]
                  ]
              }
          ancestorRule2 = RelationRule
              { headVariables = ["X", "Y"]
              , bodyElements =
                  [ ruleBody "parent" [0, 1] ]
              }
          ancestorRelation =
            Relation
              { _arity = 2
              , _name = "ancestor"
              , _tuples = Set.empty
              , _rules = [ancestorRule, ancestorRule2]
              }

      constants db
        `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])

      relations db
        `shouldBe` Map.fromList
          [ ("ancestor", ancestorRelation)
          , ("parent", parentRelation)
          ]

    it "can ingest facts and rules with constants" do
      let db =
            InMemoryDB.withFactsAndRules
              []
              ["ancestor(X,\"patriarch\") :- ."]
          ancestorRule =
            RelationRule
              { headVariables = ["X"]
              , bodyElements = []
              }
          ancestorRelation =
            Relation
              { _arity = 2
              , _name = "ancestor"
              , _tuples = Set.empty
              , _rules = [ancestorRule]
              }
      relations db
        `shouldBe` Map.singleton "ancestor" ancestorRelation

      constants db
        `shouldBe` Set.fromList (Sym <$> ["patriarch"])

    it "can ingest facts and rules with duplicate head entries" do
      let db =
            InMemoryDB.withFactsAndRules
              []
              ["equivalent(Q,Q) :- ."]
          equivalentRule =
            RelationRule
              { headVariables = ["Q"]
              , bodyElements = []
              }
          equivalentRelation =
            Relation
              { _arity = 2
              , _name = "equivalent"
              , _tuples = Set.empty
              , _rules = [equivalentRule]
              }
      relations db
        `shouldBe` Map.singleton "equivalent" equivalentRelation

      constants db
        `shouldBe` Set.empty

    it "can ingest a theory of equivalence relations" do
      let db =
            InMemoryDB.withFactsAndRules
              []
              [ "equivalent(Q,Q) :- ."
              , "equivalent(R,Q) :- equivalent(Q,R)."
              , "equivalent(Q,S) :- equivalent(Q,R), equivalent(R,S)."
              ]
          rule1 =
            RelationRule
              { headVariables = ["Q"]
              , bodyElements = []
              }
          rule2 =
            RelationRule
              { headVariables = ["R", "Q"]
              , bodyElements =
                  [ ruleBody "equivalent" [1, 0] ]
              }
          rule3 =
            RelationRule
              { headVariables = ["Q", "S", "R"]
              , bodyElements =
                  [ ruleBody "equivalent" [0, 2]
                  , ruleBody "equivalent" [2, 1]
                  ]
              }
          equivalentRelation =
            Relation
              { _arity = 2
              , _name = "equivalent"
              , _tuples = Set.empty
              , _rules = [rule1, rule2, rule3]
              }
      relations db
        `shouldBe` Map.singleton "equivalent" equivalentRelation

      constants db
        `shouldBe` Set.empty

    it "can do basic queries" do
      let db :: InMemoryDB =
            InMemoryDB.withFacts
              [ "parent(\"alice\", \"bob\")."
              , "parent(\"bob\", \"carol\")."
              ]
      query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'

(<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<<$>>) = fmap fmap fmap

-- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (f2 (a -> b)) -> f1 (f2 (f3 a -> f3 b))
-- (<<<$>>>) :: Functor f => (a1 -> b) -> (a2 -> a1) -> f a2 -> f b
-- (<<<$>>>) :: (Functor f1, Functor f2) => (a1 -> a2 -> b) -> f1 a1 -> f1 (f2 a2 -> f2 b)
-- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (a -> b) -> f1 (f2 (f3 a) -> f2 (f3 b))
(<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => (a -> b) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b))
(<<<$>>>) = fmap fmap fmap fmap fmap fmap fmap fmap

ruleBody :: Text -> [Int] -> RuleBodyElement
ruleBody subRelationId indices =
  RuleBodyElement
    { _subRelationId = subRelationId
    , _ruleElements =
      RuleElementVariable <$> indices
    }