added relation references
This commit is contained in:
parent
585da9f794
commit
7855e5ce20
@ -33,9 +33,14 @@ data RuleElement = -- entry occurring in a head or body relation - constant or v
|
|||||||
RuleElementVariable Text
|
RuleElementVariable Text
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data RuleBodyElement = RuleBodyElement {
|
||||||
|
_subRelationName :: Text,
|
||||||
|
_ruleElements :: [RuleElement]
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
data RelationRule = RelationRule {
|
data RelationRule = RelationRule {
|
||||||
headVariables :: [Text],
|
headVariables :: [Text],
|
||||||
body :: [(Relation, [RuleElement])]
|
bodyElements :: [RuleBodyElement]
|
||||||
} deriving (Show, Eq)
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
data Relation = Relation {
|
data Relation = Relation {
|
||||||
@ -201,11 +206,14 @@ withFactsAndRules facts rules =
|
|||||||
extractVarName (RuleElementConstant constant) = throw $ UnexpectedConstantException constant
|
extractVarName (RuleElementConstant constant) = throw $ UnexpectedConstantException constant
|
||||||
newRule = RelationRule {
|
newRule = RelationRule {
|
||||||
headVariables = extractVarName <$> variables',
|
headVariables = extractVarName <$> variables',
|
||||||
body = fromBodyConstraint <$> (_bodyConstraints context'')
|
bodyElements = fromBodyConstraint <$> (_bodyConstraints context'')
|
||||||
} where
|
} where
|
||||||
fromBodyConstraint :: BodyConstraint -> (Relation, [RuleElement])
|
fromBodyConstraint :: BodyConstraint -> RuleBodyElement
|
||||||
fromBodyConstraint (BodyConstraint subRelation elements) =
|
fromBodyConstraint (BodyConstraint subRelation elements) =
|
||||||
(subRelation, toRuleElement <$> elements)
|
RuleBodyElement {
|
||||||
|
_subRelationName = _name subRelation,
|
||||||
|
_ruleElements = toRuleElement <$> elements
|
||||||
|
}
|
||||||
toRuleElement :: ConstraintElement -> RuleElement
|
toRuleElement :: ConstraintElement -> RuleElement
|
||||||
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
|
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
|
||||||
toRuleElement (ConstraintElementIndex index) = variables' !! index
|
toRuleElement (ConstraintElementIndex index) = variables' !! index
|
||||||
|
|||||||
@ -50,40 +50,34 @@ spec = do
|
|||||||
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]],
|
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]],
|
||||||
_rules = []
|
_rules = []
|
||||||
}
|
}
|
||||||
|
let ancestorRule = RelationRule {
|
||||||
|
headVariables = [ "X", "Y", "Z" ],
|
||||||
|
bodyElements = [
|
||||||
|
RuleBodyElement {
|
||||||
|
_subRelationName = "parent",
|
||||||
|
_ruleElements = [
|
||||||
|
RuleElementVariable "X", RuleElementVariable "Z"
|
||||||
|
]
|
||||||
|
},
|
||||||
|
RuleBodyElement {
|
||||||
|
_subRelationName = "ancestor",
|
||||||
|
_ruleElements = [
|
||||||
|
RuleElementVariable "Z",RuleElementVariable "Y"
|
||||||
|
]
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
let ancestorRelation = Relation {
|
let ancestorRelation = Relation {
|
||||||
_arity = 2,
|
_arity = 2,
|
||||||
_name = "ancestor",
|
_name = "ancestor",
|
||||||
_tuples = Set.empty,
|
_tuples = Set.empty,
|
||||||
_rules = []
|
_rules = [ ancestorRule ]
|
||||||
}
|
}
|
||||||
relations db `shouldBe`
|
relations db `shouldBe`
|
||||||
Map.fromList [
|
Map.fromList [
|
||||||
("ancestor",
|
("ancestor", ancestorRelation),
|
||||||
Relation {
|
("parent", parentRelation )
|
||||||
_arity = 2,
|
]
|
||||||
_name = "ancestor",
|
|
||||||
_tuples = Set.empty,
|
|
||||||
_rules = [
|
|
||||||
RelationRule {
|
|
||||||
headVariables = [ "X", "Y", "Z" ],
|
|
||||||
body = [
|
|
||||||
(
|
|
||||||
parentRelation, [
|
|
||||||
RuleElementVariable "X",
|
|
||||||
RuleElementVariable "Z"
|
|
||||||
]
|
|
||||||
),(
|
|
||||||
ancestorRelation,[
|
|
||||||
RuleElementVariable "Z",
|
|
||||||
RuleElementVariable "Y"
|
|
||||||
]
|
|
||||||
)
|
|
||||||
]
|
|
||||||
}
|
|
||||||
]
|
|
||||||
} ),
|
|
||||||
("parent", parentRelation )
|
|
||||||
]
|
|
||||||
|
|
||||||
it "can do basic queries" $ do
|
it "can do basic queries" $ do
|
||||||
let db = NaiveDatabase.withFacts
|
let db = NaiveDatabase.withFacts
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user