tests for ingesting facts

haskell-experiments/haskell-experiments.cabal

@@ -77,7 +77,7 @@ test-suite haskell-exps-test
     main-is:          Main.hs
 
     -- Test dependencies.
-    build-depends:    base, hspec, langfeatures, megaparsec
+    build-depends:    base, containers, megaparsec, hspec, langfeatures
     other-modules:    Test.OlogsSpec,
       Test.SimpleParserSpec,
       Test.ArithmeticParserSpec,

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -30,7 +30,7 @@ data NaiveDatabase = NaiveDatabase {
 data Relation = Relation {
   arity :: Int,
   tuples :: Set [Constant]
-}
+} deriving (Show, Eq)
 
 -- newtype RelationId = RelationId Text
 --   deriving (Eq, Ord, Show)
@@ -60,10 +60,15 @@ withFacts facts =
     addFact :: NaiveDatabase -> Literal -> NaiveDatabase
     addFact (NaiveDatabase relations constants) (Literal neg relationName terms) =
       NaiveDatabase newRelations newConstants where
-        newRelations =
+        newArity = length terms
+        newRelation =
           case Map.lookup relationName relations of
-            Nothing -> relations
-            Just relation -> relations
+            Nothing -> Relation (length terms) (Set.singleton terms)
+            Just relation ->
+              if (arity relation == newArity)
+                then Relation (length terms) (Set.singleton terms)
+                else throw $ BadArityException relationName newArity
+        newRelations = Map.insert relationName newRelation relations 
         newConstants = Set.union constants $ Set.fromList terms
 
 query :: NaiveDatabase -> Text -> Text
@@ -76,7 +81,8 @@ query db qText =
 data NaiveDatabaseException
   = CannotParseStatementException Text (ParseErrorBundle Text Void) |
     NonFactException Text Statement |
-    NonQueryException Text Statement
+    NonQueryException Text Statement |
+    BadArityException Text Int
   deriving (Show)
 
 instance Exception NaiveDatabaseException

haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs

@@ -8,61 +8,36 @@
 {-# LANGUAGE NoFieldSelectors #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 
 module Test.Datalog.NaiveDatabaseSpec where
 
 import Test.Hspec
 import Datalog.NaiveDatabase
 import qualified Datalog.NaiveDatabase as NaiveDatabase
-
--- checkParse :: String -> Expr -> Expectation
--- checkParse text expectedExpr = 
---   parse parseExpr "" text `shouldBe` Right expectedExpr
-
--- checkEval :: String -> Int -> Expectation
--- checkEval text expectedVal = 
---   fmap eval (parse parseExpr "" text) `shouldBe` Right expectedVal
-
--- getConfig :: IO Config
--- getConfig = do
---   env <- lookupEnv "APP_ENV"
---   let fallbackHosts =
---         [ "localhost:8080"
---         , "127.0.0.1:9000"
---         , "backup.example.com"
---         ]
---   pure Config
---     { port     = 3000
---     , hosts    = fromMaybe fallbackHosts env
---     , logLevel = Info
---     }
+import Data.Set qualified as Set
+import Datalog.DatalogParser
+import qualified Data.Map as Map
 
 spec :: Spec
 spec = do
   describe "dummy test" $ do
     it "..." $ do
       1 `shouldBe` (1 :: Int)
-    it "can accept facts and do basic queries" $ do
-      -- let fallbackHosts =
-      --       [ "localhost:8080"
-      --       , "127.0.0.1:9000"
-      --       , "backup.example.com"
-      --       ]
-      -- let names =
-      --       [ "Alice"
-      --       , "Bob"
-      --       , "Charlie"
-      --       , "Daphne"
-      --       , "Eve"
-      --       ]
-      -- let twig = 
-      --       [ "xx"
-      --       , "yy "  ]
-      -- let pig = 
-      --       [ "parent(\"alice\", \"bob\")."
-      --       , "parent(\"bob\", \"carol\")." 
-      --       ]
+    it "can ingest facts into relations & a universe" $ do
       let db = NaiveDatabase.withFacts 
             [ "parent(\"alice\", \"bob\")."
             , "parent(\"bob\", \"carol\")." ]
-      query  db"?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'
+      constants db `shouldBe` 
+        (Set.fromList $ Sym <$> ["alice", "bob", "carol"])
+      relations db `shouldBe`
+        Map.fromList [
+          ("parent",  
+            Relation 2 $ Set.fromList $ [Sym <$> ["bob", "carol"]])
+        ]
+
+    it "can do basic queries" $ do
+      let db = NaiveDatabase.withFacts 
+            [ "parent(\"alice\", \"bob\")."
+            , "parent(\"bob\", \"carol\")." ]
+      query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'