diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index cba3aed..5ea6eb9 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -11,7 +11,7 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import qualified Data.Text as T -import Datalog.DatalogParser +import Datalog.DatalogParser(parseDatalog, Literal(Literal), Statement(..)) import qualified Data.Map as Map import Text.Megaparsec (ParseErrorBundle) import Data.Void @@ -71,6 +71,21 @@ withFacts facts = newRelations = Map.insert relationName newRelation relations newConstants = Set.union constants $ Set.fromList terms +withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase +withFactsAndRules facts rules = + foldl addRule (withFacts facts) (extractRule <$> rules) where + extractRule:: Text -> (Literal, [Literal]) + extractRule ruleText = + case (parseDatalog ruleText) of + Right (Rule lhs rhs) -> (lhs, rhs) + Right otherStatement -> throw $ NonRuleException ruleText otherStatement + Left ex -> throw $ CannotParseStatementException ruleText ex + addRule :: NaiveDatabase -> Literal -> [Literal] -> NaiveDatabase + addRule (NaiveDatabase relations constants) (Literal neg relationName terms) body = + NaiveDatabase newRelations newConstants where + newRelations = relations + newConstants = constants + query :: NaiveDatabase -> Text -> Text query db qText = case (parseDatalog qText) of @@ -81,6 +96,7 @@ query db qText = data NaiveDatabaseException = CannotParseStatementException Text (ParseErrorBundle Text Void) | NonFactException Text Statement | + NonRuleException Text Statement | NonQueryException Text Statement | BadArityException Text Int deriving (Show) diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 2d03d64..3c0b59e 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -35,6 +35,19 @@ spec = do ("parent", Relation 2 $ Set.fromList $ [Sym <$> ["bob", "carol"]]) ] + it "can ingest facts and rules" $ do + let db = NaiveDatabase.withFactsAndRules + [ "parent(\"alice\", \"bob\")." + , "parent(\"bob\", \"carol\")." ] + [ "ancestor(X,Y) :- parent(X,Y)." + , "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." ] + 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