From 72f973c195b1bb6b6779973e10bdc631dddc4e81 Mon Sep 17 00:00:00 2001
From: Felix Dilke <felix.dilke@obsidian.systems>
Date: Fri, 30 Jan 2026 10:47:27 +0000
Subject: [PATCH] lift up addRule

---
 haskell-experiments/src/Datalog/DatalogDB.hs  |  1 +
 .../src/Datalog/NaiveDatabase.hs              | 58 +++++++++----------
 2 files changed, 29 insertions(+), 30 deletions(-)

diff --git a/haskell-experiments/src/Datalog/DatalogDB.hs b/haskell-experiments/src/Datalog/DatalogDB.hs
index 2dba7b6..5f7aaa2 100644
--- a/haskell-experiments/src/Datalog/DatalogDB.hs
+++ b/haskell-experiments/src/Datalog/DatalogDB.hs
@@ -23,3 +23,4 @@ class DatalogDB db where
   emptyDB :: db
   lookupRelation :: db -> Text -> Maybe Relation
   insertRelation :: db -> Relation -> db
+  addRule :: (Literal, [Literal]) -> db -> db
\ No newline at end of file
diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs
index c0fdbd1..ef38eb2 100644
--- a/haskell-experiments/src/Datalog/NaiveDatabase.hs
+++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs
@@ -45,6 +45,34 @@ instance DatalogDB NaiveDatabase where
       relations = Map.insert (_name relation) relation (relations db)
     }
 
+  addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
+  addRule (ruleHead, body) db  =
+    NaiveDatabase relationMap' constants' 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'
+      relationMap = relations db'
+      relation' = appendRule relation RelationRule { 
+          headVariables = _variableNames context'
+          , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
+        }
+      relationMap' = Map.insert relationName relation' relationMap
+      constants' = 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 =
@@ -57,7 +85,6 @@ lookupRelation00 relationName db newArity update =
             relation
           else throw $ BadArityException relationName newArity
 
-
 lookupRelation000:: DatalogDB db => 
   Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
 lookupRelation000 relationName db newArity tuples update =
@@ -65,17 +92,6 @@ lookupRelation000 relationName db newArity tuples update =
     update relation { 
       _tuples = Set.union tuples $ _tuples relation 
     }
-    
-
-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
 
 withFacts :: [Text] -> NaiveDatabase
 withFacts =
@@ -162,24 +178,6 @@ lookupVariable varName variableNames =
       Just index -> index
       Nothing -> throw $ VariableLookupException varName variableNames
 
-addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
-addRule (ruleHead, body) db  =
-  NaiveDatabase relationMap' constants' 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'
-    relationMap = relations db'
-    relation' = appendRule relation RelationRule { 
-        headVariables = _variableNames context'
-        , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
-      }
-    relationMap' = Map.insert relationName relation' relationMap
-    constants' = constants db'
-
 query :: NaiveDatabase -> Text -> Text
 query db qText =
   case parseDatalog qText of