fdilke/pyrites
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

digestBody uses the typeclass

Browse Source
This commit is contained in:
Felix Dilke 2026-01-30 12:08:29 +00:00
parent 55b12f5c00
commit e01a1ba3df
1 changed files with 5 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
haskell-experiments/src/Datalog/NaiveDatabase.hs
View File

@ -150,24 +150,23 @@ digestHead db relation (Literal neg relationName terms) =
extractConstant :: RuleElement -> Maybe Constant
extractConstant (RuleElementConstant constant) = Just constant
extractConstant _ = Nothing
digestBody :: Literal -> RuleContext NaiveDatabase -> RuleContext NaiveDatabase
digestBody :: forall db . (DatalogDB db) => Literal -> RuleContext db -> RuleContext db
digestBody (Literal neg subRelationName subTerms) context =
context {
_variableNames = variableNames
, _bodyConstraints = newConstraint : constraints
, _db = NaiveDatabase relationMap' constants'
, _db = insertRelation (addConstants db constants') subRelation
}
where
db = _db context
variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
newArity = length subTerms
subRelation = lookupRelation0 subRelationName (_db context) newArity Set.empty
relationMap :: Map RelationId Relation = relations (_db context)
relationMap' = Map.insert subRelationName subRelation relationMap
extraConstants = mapMaybe constantFromTerm subTerms where
constantFromTerm :: Term -> Maybe Constant
constantFromTerm (Var _) = Nothing
constantFromTerm constant = Just constant
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
constants' = Set.fromList extraConstants
constraints = _bodyConstraints context
newConstraint = BodyConstraint subRelation subRuleElements where
subRuleElements = toRuleElement <$> subTerms
@ -182,7 +181,7 @@ lookupVariable varName variableNames =
headTermToElement :: [Text] -> Term -> RuleElement
headTermToElement variableNames (Var name) =
RuleElementVariable $ lookupVariable name variableNames
headTermToElement variableNames constant = RuleElementConstant constant
headTermToElement _ constant = RuleElementConstant constant
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)