diff --git a/haskell-experiments/haskell-experiments.cabal b/haskell-experiments/haskell-experiments.cabal index fbd49d1..da1be79 100644 --- a/haskell-experiments/haskell-experiments.cabal +++ b/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, diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index df45e6d..cba3aed 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/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 \ No newline at end of file diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 654a406..2d03d64 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/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'