diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 5ea6eb9..eae567e 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(parseDatalog, Literal(Literal), Statement(..)) +import Datalog.DatalogParser(parseDatalog, Literal(Literal), Statement(..), Term, Head (HeadSingle)) import qualified Data.Map as Map import Text.Megaparsec (ParseErrorBundle) import Data.Void @@ -27,9 +27,20 @@ data NaiveDatabase = NaiveDatabase { constants :: Set Constant } +data BodyEntry = -- entry occurring in a head or body relation - constant or variable + BodyEntryConstant Constant | + BodyEntryVariable Text + deriving (Show, Eq) + +data RelationRule = RelationRule { + headVariables :: [BodyEntry], + body :: [(Relation, [BodyEntry])] +} deriving (Show, Eq) + data Relation = Relation { arity :: Int, - tuples :: Set [Constant] + tuples :: Set [Constant], + rules :: [RelationRule] } deriving (Show, Eq) -- newtype RelationId = RelationId Text @@ -63,10 +74,10 @@ withFacts facts = newArity = length terms newRelation = case Map.lookup relationName relations of - Nothing -> Relation (length terms) (Set.singleton terms) + Nothing -> Relation (length terms) (Set.singleton terms) [] Just relation -> if (arity relation == newArity) - then Relation (length terms) (Set.singleton terms) + 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 @@ -77,11 +88,11 @@ withFactsAndRules facts rules = extractRule:: Text -> (Literal, [Literal]) extractRule ruleText = case (parseDatalog ruleText) of - Right (Rule lhs rhs) -> (lhs, rhs) + Right (Rule (HeadSingle 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 = + addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase + addRule (NaiveDatabase relations constants) ((Literal neg relationName terms), body) = NaiveDatabase newRelations newConstants where newRelations = relations newConstants = constants diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 3c0b59e..b4a691a 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -33,7 +33,7 @@ spec = do relations db `shouldBe` Map.fromList [ ("parent", - Relation 2 $ Set.fromList $ [Sym <$> ["bob", "carol"]]) + Relation 2 (Set.fromList ([Sym <$> ["bob", "carol"]])) [] ) ] it "can ingest facts and rules" $ do let db = NaiveDatabase.withFactsAndRules @@ -46,7 +46,7 @@ spec = do relations db `shouldBe` Map.fromList [ ("parent", - Relation 2 $ Set.fromList $ [Sym <$> ["bob", "carol"]]) + Relation 2 (Set.fromList ([Sym <$> ["bob", "carol"]])) [] ) ] it "can do basic queries" $ do