factored out addFact, addRule

haskell-experiments/src/Datalog/DatalogDB.hs

@@ -23,7 +23,97 @@ class DatalogDB db where
   emptyDB :: db
   lookupRelation :: db -> Text -> Maybe Relation
   insertRelation :: db -> Relation -> db
-  addFact :: Literal -> db -> db
-  addRule :: (Literal, [Literal]) -> db -> db
   addConstants :: db -> Set Constant -> db
 
+lookupRelationArity :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation
+lookupRelationArity relationName db newArity tuples =
+  case lookupRelation db relationName of
+    Nothing -> Relation relationName newArity tuples []
+    Just relation ->
+      if _arity relation == newArity then
+          let newTuples = Set.union tuples $ _tuples relation
+           in relation { _tuples = newTuples }
+        else throw $ BadArityException relationName newArity
+
+addFact :: (DatalogDB db) => Literal -> db -> db
+addFact (Literal neg relationName terms) db =
+  insertRelation (addConstants db extraConstants) newRelation
+  where
+  newArity = length terms
+  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

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -43,46 +43,12 @@ instance DatalogDB NaiveDatabase where
       relations = Map.insert (_name relation) relation (relations db)
     }
 
-  addFact :: Literal -> NaiveDatabase -> NaiveDatabase
-  addFact (Literal neg relationName terms) db@(NaiveDatabase relationMap constantSet) =
-    insertRelation (addConstants db extraConstants) newRelation
-   where
-    newArity = length terms
-    newRelation = lookupRelation0 relationName db newArity (Set.singleton terms)
-    extraConstants = Set.fromList terms
-
-  addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
-  addRule (ruleHead, body) db  =
-    insertRelation db' newRelation
-    where
-      relationName = predName ruleHead
-      terms = arguments ruleHead
-      newArity = length terms
-      relation = lookupRelation0 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'
-        }
-
   addConstants :: NaiveDatabase -> Set Constant -> NaiveDatabase
   addConstants db newConstants =
     db {
       constants = Set.union newConstants (constants db)
     }
 
-lookupRelation0 :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation
-lookupRelation0 relationName db newArity tuples =
-  case lookupRelation db relationName of
-    Nothing -> Relation relationName newArity tuples []
-    Just relation ->
-      if _arity relation == newArity then
-          let newTuples = Set.union tuples $ _tuples relation
-           in relation { _tuples = newTuples }
-        else throw $ BadArityException relationName newArity
-
 lookupRelation00 :: DatalogDB db => 
   Text -> db -> Int -> (Relation -> Relation) -> db
 lookupRelation00 relationName db newArity update =
@@ -114,64 +80,6 @@ withFacts =
       Right otherStatement -> throw $ NonFactException factText otherStatement
       Left ex -> throw $ CannotParseStatementException factText ex
 
-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 = lookupRelation0 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
 
 withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
 withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)

haskell-experiments/src/Datalog/Rules.hs

@@ -89,3 +89,4 @@ data DatalogDBException
   deriving (Show)
 
 instance Exception DatalogDBException
+