From 95e81faa7cf9e75650e1b5fdd802abfcbb24e7df Mon Sep 17 00:00:00 2001 From: Felix Dilke Date: Tue, 27 Jan 2026 18:40:05 +0000 Subject: [PATCH] broken test: failing to look up Z --- .../src/Datalog/NaiveDatabase.hs | 100 ++++++++++-------- .../test/Test/Datalog/NaiveDatabaseSpec.hs | 8 +- 2 files changed, 58 insertions(+), 50 deletions(-) diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 5b5f833..0c62e92 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -30,7 +30,7 @@ data NaiveDatabase = NaiveDatabase data RuleElement -- entry occurring in a head or body relation - constant or variable = RuleElementConstant Constant - | RuleElementVariable Text + | RuleElementVariable Int deriving (Show, Eq) data RuleBodyElement = RuleBodyElement @@ -93,14 +93,9 @@ lookupRelation relationName relationMap newArity tuples = in Relation relationName newArity newTuples [] else throw $ BadArityException relationName newArity -data ConstraintElement -- entry occurring in a rule body constraint - constant or variable index - = ConstraintElementConstant Constant - | ConstraintElementIndex Int - deriving (Show, Eq) - data BodyConstraint = BodyConstraint { _relation :: Relation - , _elements :: [ConstraintElement] + , _elements :: [RuleElement] } data RuleContext = RuleContext @@ -128,51 +123,65 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) digestHead db relation (Literal neg relationName terms) = RuleContext { __relation = relation - , _variableNames = extractVariableNames terms - , _headEntries = variables' + , _variableNames = variableNames + , _headEntries = entries' , _bodyConstraints = [] , _db = NaiveDatabase relationMap' constants' } where + variableNames = extractVariableNames terms + headTermToElement :: Term -> RuleElement + headTermToElement (Var name) = + case (elemIndex name) variableNames of + Just index -> RuleElementVariable index + Nothing -> throw $ VariableLookupException name variableNames + headTermToElement constant = RuleElementConstant constant relationMap :: Map RelationId Relation = relations db relationMap' = Map.insert relationName relation relationMap - extraVariables = toElement <$> terms - variables' = nub extraVariables - extraConstants = mapMaybe maybeConstant variables' + extraVariables = headTermToElement <$> terms + entries' = nub extraVariables + extraConstants = mapMaybe maybeConstant entries' constants' = Set.union (constants db) $ Set.fromList extraConstants digestBody :: RuleContext -> Literal -> RuleContext digestBody context (Literal neg subRelationName terms) = RuleContext { __relation = relation - , _variableNames = _variableNames context + , _variableNames = variableNames , _headEntries = variables' , _bodyConstraints = constraints' , _db = NaiveDatabase relationMap' constants' } where relation = __relation context + variableNames = _variableNames context + bodyTermToElement :: Term -> RuleElement + bodyTermToElement (Var name) = + case (elemIndex name) variableNames of + Just index -> RuleElementVariable index + Nothing -> throw $ VariableLookupException name variableNames + bodyTermToElement constant = RuleElementConstant constant newArity = length terms subRelation = lookupRelation subRelationName relationMap newArity Set.empty relationMap :: Map RelationId Relation = relations (_db context) relationMap' = Map.insert subRelationName subRelation relationMap - extraVariables = toElement <$> terms + extraVariables = bodyTermToElement <$> terms extraConstants = mapMaybe maybeConstant extraVariables variables' = nub $ _headEntries context ++ extraVariables constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants constraints = _bodyConstraints context - newConstraint = BodyConstraint subRelation (toConstraint <$> terms) + newConstraint = BodyConstraint subRelation variables' constraints' = constraints ++ [newConstraint] - varIndex :: Text -> Int - varIndex name = - case elemIndex (RuleElementVariable name) variables' of - Just index -> index - Nothing -> throw $ VariableLookupException name variables' - toConstraint :: Term -> ConstraintElement - toConstraint (Var name) = ConstraintElementIndex (varIndex name) - toConstraint constant = ConstraintElementConstant constant + -- varIndex :: Text -> Int + -- varIndex name = + -- case elemIndex (RuleElementVariable name) variables' of + -- Just index -> index + -- Nothing -> throw $ VariableLookupException name variables' + -- toConstraint :: Term -> ConstraintElement + -- toConstraint (Var name) = ConstraintElementIndex (varIndex name) + -- toConstraint constant = ConstraintElementConstant constant addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase addRule (ruleHead, body) db = - NaiveDatabase newRelationMap constants' + NaiveDatabase relationMap' constants' where relationName = predName ruleHead terms = arguments ruleHead @@ -182,25 +191,24 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) context' = foldl digestBody context body db' = _db context' relationMap = relations db' - variables' = _headEntries context' - extractVarName :: RuleElement -> Maybe Text - extractVarName (RuleElementVariable varName) = Just varName - extractVarName (RuleElementConstant constant) = Nothing + -- variables' = _headEntries context' + -- extractVarName :: RuleElement -> Maybe Text + -- extractVarName (RuleElementVariable varName) = Just varName + -- extractVarName (RuleElementConstant constant) = Nothing newRule = RelationRule - { headVariables = mapMaybe extractVarName variables' - , bodyElements = fromBodyConstraint <$> _bodyConstraints context' - } - where - fromBodyConstraint :: BodyConstraint -> RuleBodyElement - fromBodyConstraint (BodyConstraint subRelation elements) = - RuleBodyElement - { _subRelationId = _name subRelation - , _ruleElements = toRuleElement <$> elements - } - toRuleElement :: ConstraintElement -> RuleElement - toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant - toRuleElement (ConstraintElementIndex index) = variables' !! index + { headVariables = _variableNames context' + , bodyElements = toRuleBodyElement <$> _bodyConstraints context' + } where + toRuleBodyElement :: BodyConstraint -> RuleBodyElement + toRuleBodyElement (BodyConstraint subRelation elements) = + RuleBodyElement { + _subRelationId = _name subRelation + , _ruleElements = elements + } + -- toRuleElement :: ConstraintElement -> RuleElement + -- toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant + -- toRuleElement (ConstraintElementIndex index) = variables' !! index relation' = Relation { _name = _name relation @@ -208,11 +216,11 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) , _tuples = _tuples relation , _rules = newRule : _rules relation } - newRelationMap = Map.insert relationName relation' relationMap + relationMap' = Map.insert relationName relation' relationMap constants' = constants db' - toElement :: Term -> RuleElement - toElement (Var name) = RuleElementVariable name - toElement constant = RuleElementConstant constant + -- toElement :: Term -> RuleElement + -- toElement (Var name) = RuleElementVariable name + -- toElement constant = RuleElementConstant constant extractVariableNames :: [Term] -> [Text] extractVariableNames = mapMaybe extractVariableName where extractVariableName :: Term -> Maybe Text @@ -232,7 +240,7 @@ data NaiveDatabaseException | NonRuleException Text Statement | NonQueryException Text Statement | BadArityException Text Int - | VariableLookupException Text [RuleElement] + | VariableLookupException Text [Text] | UnexpectedConstantException Constant deriving (Show) diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 544326b..7909679 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -65,15 +65,15 @@ spec = do [ RuleBodyElement { _subRelationId = "parent" , _ruleElements = - [ RuleElementVariable "X" - , RuleElementVariable "Z" + [ RuleElementVariable 0 + , RuleElementVariable 2 ] } , RuleBodyElement { _subRelationId = "ancestor" , _ruleElements = - [ RuleElementVariable "Z" - , RuleElementVariable "Y" + [ RuleElementVariable 2 + , RuleElementVariable 1 ] } ]