digestHead refactor

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -126,10 +126,6 @@ data RuleContext = RuleContext
   , _db :: NaiveDatabase
   }
 
-withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
-withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
- where
-
 digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
 digestHead db relation (Literal neg relationName terms) =
   RuleContext
@@ -137,7 +133,7 @@ digestHead db relation (Literal neg relationName terms) =
     , _variableNames = variableNames
     , _headEntries = entries'
     , _bodyConstraints = []
-    , _db = NaiveDatabase relationMap' constants'
+    , _db = insertRelation (addConstants db extraConstants) relation
     }
  where
   variableNames = nub $ extractVariableNames terms
@@ -145,16 +141,12 @@ digestHead db relation (Literal neg relationName terms) =
   headTermToElement (Var name) = 
     RuleElementVariable $ lookupVariable name variableNames
   headTermToElement constant = RuleElementConstant constant
-  -- db' = insertRelation db relation
-  relationMap :: Map RelationId Relation = relations db
-  relationMap' = Map.insert relationName relation relationMap
   extraVariables = headTermToElement <$> terms
   entries' = nub extraVariables
-  extraConstants = mapMaybe extractConstant entries' where
+  extraConstants = Set.fromList $ mapMaybe extractConstant entries' where
     extractConstant :: RuleElement -> Maybe Constant
     extractConstant (RuleElementConstant constant) = Just constant
     extractConstant _ = Nothing
-  constants' = Set.union (constants db) $ Set.fromList extraConstants
 digestBody :: Literal -> RuleContext -> RuleContext
 digestBody (Literal neg subRelationName subTerms) context =
   context { 
@@ -185,6 +177,9 @@ lookupVariable varName variableNames =
       Just index -> index
       Nothing -> throw $ VariableLookupException varName variableNames
 
+withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
+withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
+
 query :: NaiveDatabase -> Text -> Text
 query db qText =
   case parseDatalog qText of