diff --git a/haskell-experiments/src/Datalog/DatalogDB.hs b/haskell-experiments/src/Datalog/DatalogDB.hs index 1383a9e..8a689cd 100644 --- a/haskell-experiments/src/Datalog/DatalogDB.hs +++ b/haskell-experiments/src/Datalog/DatalogDB.hs @@ -8,16 +8,54 @@ module Datalog.DatalogDB where import Control.Exception.Base import Data.List -import Data.Map (Map) -import Data.Map qualified as Map import Data.Maybe import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) -import Data.Void -import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog) +import Datalog.DatalogParser (Literal (..), Term (..), Statement) import Text.Megaparsec (ParseErrorBundle) -import Datalog.Rules +import Data.Void + +data Relation = Relation + { _name :: RelationId + , _arity :: Int + , _tuples :: Set [Constant] + , _rules :: [RelationRule] + } + deriving (Show, Eq) + +data RelationRule = RelationRule + { headVariables :: [Text] + , bodyElements :: [RuleBodyElement] + } + deriving (Show, Eq) + +data RuleBodyElement = RuleBodyElement + { _subRelationId :: RelationId + , _ruleElements :: [RuleElement] + } + deriving (Show, Eq) + +data RuleElement -- entry occurring in a head or body relation - constant or variable + = RuleElementConstant Constant + | RuleElementVariable Int + deriving (Show, Eq) + +data DatalogDBException + = CannotParseStatementException Text (ParseErrorBundle Text Void) + | NonFactException Text Statement + | NonRuleException Text Statement + | NonQueryException Text Statement + | BadArityException Text Int + | VariableLookupException Text [Text] + | UnexpectedConstantException Constant + deriving (Show) + +instance Exception DatalogDBException + +-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols +type Constant = Term +type RelationId = Text class DatalogDB db where emptyDB :: db @@ -43,77 +81,3 @@ addFact (Literal neg relationName terms) db = newRelation = lookupRelationArity relationName db newArity (Set.singleton terms) extraConstants = Set.fromList terms -addRule :: (DatalogDB db) => (Literal, [Literal]) -> db -> db -addRule (ruleHead, body) db = - insertRelation db' newRelation - where - relationName = predName ruleHead - terms = arguments ruleHead - newArity = length terms - relation = lookupRelationArity relationName db newArity Set.empty - context = digestHead db relation ruleHead - context' = foldr digestBody context body - db' = _db context' - newRelation = appendRule relation RelationRule { - headVariables = _variableNames context' - , bodyElements = toRuleBodyElement <$> _bodyConstraints context' - } - -data (DatalogDB db) => RuleContext db = RuleContext - { __relation :: Relation - , _variableNames :: [Text] - , _headEntries :: [RuleElement] - , _bodyConstraints :: [BodyConstraint] - , _db :: db - } - -digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db -digestHead db relation (Literal neg relationName terms) = - RuleContext - { __relation = relation - , _variableNames = variableNames - , _headEntries = entries' - , _bodyConstraints = [] - , _db = insertRelation (addConstants db extraConstants) relation - } - where - variableNames = nub $ extractVariableNames terms - entries' = nub $ (headTermToElement variableNames) <$> terms - extraConstants = Set.fromList $ mapMaybe extractConstant entries' where - extractConstant :: RuleElement -> Maybe Constant - extractConstant (RuleElementConstant constant) = Just constant - extractConstant _ = Nothing -digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db -digestBody (Literal neg subRelationName subTerms) context = - context { - _variableNames = variableNames - , _bodyConstraints = newConstraint : constraints - , _db = insertRelation (addConstants db constants') subRelation - } - where - db = _db context - variableNames = nub $ _variableNames context ++ extractVariableNames subTerms - newArity = length subTerms - subRelation = lookupRelationArity subRelationName (_db context) newArity Set.empty - extraConstants = mapMaybe constantFromTerm subTerms where - constantFromTerm :: Term -> Maybe Constant - constantFromTerm (Var _) = Nothing - constantFromTerm constant = Just constant - constants' = Set.fromList extraConstants - constraints = _bodyConstraints context - newConstraint = BodyConstraint subRelation subRuleElements where - subRuleElements = toRuleElement <$> subTerms - toRuleElement :: Term -> RuleElement - toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames - toRuleElement constant = RuleElementConstant constant - -lookupVariable :: Text -> [Text] -> Int -lookupVariable varName variableNames = - case elemIndex varName variableNames of - Just index -> index - Nothing -> throw $ VariableLookupException varName variableNames - -headTermToElement :: [Text] -> Term -> RuleElement -headTermToElement variableNames (Var name) = - RuleElementVariable $ lookupVariable name variableNames -headTermToElement _ constant = RuleElementConstant constant diff --git a/haskell-experiments/src/Datalog/Rules.hs b/haskell-experiments/src/Datalog/Rules.hs index b343d75..a14eda3 100644 --- a/haskell-experiments/src/Datalog/Rules.hs +++ b/haskell-experiments/src/Datalog/Rules.hs @@ -17,35 +17,7 @@ import Data.Text (Text) import Data.Void import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog) import Text.Megaparsec (ParseErrorBundle) - -data RuleElement -- entry occurring in a head or body relation - constant or variable - = RuleElementConstant Constant - | RuleElementVariable Int - deriving (Show, Eq) - -data RuleBodyElement = RuleBodyElement - { _subRelationId :: RelationId - , _ruleElements :: [RuleElement] - } - deriving (Show, Eq) - -data RelationRule = RelationRule - { headVariables :: [Text] - , bodyElements :: [RuleBodyElement] - } - deriving (Show, Eq) - -data Relation = Relation - { _name :: RelationId - , _arity :: Int - , _tuples :: Set [Constant] - , _rules :: [RelationRule] - } - deriving (Show, Eq) - --- Our constants will be the terms of the Datalog grammar - ints/variables/symbols -type Constant = Term -type RelationId = Text +import Datalog.DatalogDB data BodyConstraint = BodyConstraint { _subRelation :: Relation @@ -78,15 +50,78 @@ extractVariableNames = mapMaybe extractVariableName where extractVariableName (Var name) = Just name extractVariableName _ = Nothing -data DatalogDBException - = CannotParseStatementException Text (ParseErrorBundle Text Void) - | NonFactException Text Statement - | NonRuleException Text Statement - | NonQueryException Text Statement - | BadArityException Text Int - | VariableLookupException Text [Text] - | UnexpectedConstantException Constant - deriving (Show) +addRule :: (DatalogDB db) => (Literal, [Literal]) -> db -> db +addRule (ruleHead, body) db = + insertRelation db' newRelation + where + relationName = predName ruleHead + terms = arguments ruleHead + newArity = length terms + relation = lookupRelationArity relationName db newArity Set.empty + context = digestHead db relation ruleHead + context' = foldr digestBody context body + db' = _db context' + newRelation = appendRule relation RelationRule { + headVariables = _variableNames context' + , bodyElements = toRuleBodyElement <$> _bodyConstraints context' + } -instance Exception DatalogDBException +data (DatalogDB db) => RuleContext db = RuleContext + { __relation :: Relation + , _variableNames :: [Text] + , _headEntries :: [RuleElement] + , _bodyConstraints :: [BodyConstraint] + , _db :: db + } + +digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db +digestHead db relation (Literal neg relationName terms) = + RuleContext + { __relation = relation + , _variableNames = variableNames + , _headEntries = entries' + , _bodyConstraints = [] + , _db = insertRelation (addConstants db extraConstants) relation + } + where + variableNames = nub $ extractVariableNames terms + entries' = nub $ (headTermToElement variableNames) <$> terms + extraConstants = Set.fromList $ mapMaybe extractConstant entries' where + extractConstant :: RuleElement -> Maybe Constant + extractConstant (RuleElementConstant constant) = Just constant + extractConstant _ = Nothing +digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db +digestBody (Literal neg subRelationName subTerms) context = + context { + _variableNames = variableNames + , _bodyConstraints = newConstraint : constraints + , _db = insertRelation (addConstants db constants') subRelation + } + where + db = _db context + variableNames = nub $ _variableNames context ++ extractVariableNames subTerms + newArity = length subTerms + subRelation = lookupRelationArity subRelationName (_db context) newArity Set.empty + extraConstants = mapMaybe constantFromTerm subTerms where + constantFromTerm :: Term -> Maybe Constant + constantFromTerm (Var _) = Nothing + constantFromTerm constant = Just constant + constants' = Set.fromList extraConstants + constraints = _bodyConstraints context + newConstraint = BodyConstraint subRelation subRuleElements where + subRuleElements = toRuleElement <$> subTerms + toRuleElement :: Term -> RuleElement + toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames + toRuleElement constant = RuleElementConstant constant + +lookupVariable :: Text -> [Text] -> Int +lookupVariable varName variableNames = + case elemIndex varName variableNames of + Just index -> index + Nothing -> throw $ VariableLookupException varName variableNames + +headTermToElement :: [Text] -> Term -> RuleElement +headTermToElement variableNames (Var name) = + RuleElementVariable $ lookupVariable name variableNames +headTermToElement _ constant = RuleElementConstant constant diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 4008d34..54ed9e8 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -21,6 +21,7 @@ import Datalog.Rules import Datalog.NaiveDatabase import Datalog.NaiveDatabase qualified as NaiveDatabase import Test.Hspec +import Datalog.DatalogDB spec :: Spec spec = do