lift addFact

haskell-experiments/src/Datalog/DatalogDB.hs

@@ -23,5 +23,7 @@ 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
+

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -45,6 +45,15 @@ 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) =
+    NaiveDatabase newRelationMap newConstantSet
+   where
+    newArity = length terms
+    newRelation = lookupRelation0 relationName db newArity (Set.singleton terms)
+    newRelationMap = Map.insert relationName newRelation relationMap
+    newConstantSet = Set.union constantSet $ Set.fromList terms
+
   addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
   addRule (ruleHead, body) db  =
     NaiveDatabase relationMap' constants' where
@@ -91,7 +100,7 @@ lookupRelation00 relationName db newArity update =
             relation
           else throw $ BadArityException relationName newArity
 
-lookupRelation000:: DatalogDB db => 
+lookupRelation000 :: DatalogDB db => 
   Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
 lookupRelation000 relationName db newArity tuples update =
   lookupRelation00 relationName db newArity \relation ->
@@ -99,7 +108,7 @@ lookupRelation000 relationName db newArity tuples update =
       _tuples = Set.union tuples $ _tuples relation 
     }
 
-withFacts :: [Text] -> NaiveDatabase
+withFacts :: DatalogDB db => [Text] -> db
 withFacts =
   foldr (addFact . extractFact) emptyDB
  where
@@ -109,14 +118,6 @@ withFacts =
       Right (Fact fact) -> fact
       Right otherStatement -> throw $ NonFactException factText otherStatement
       Left ex -> throw $ CannotParseStatementException factText ex
-  addFact :: Literal -> NaiveDatabase -> NaiveDatabase
-  addFact (Literal neg relationName terms) db@(NaiveDatabase relationMap constantSet) =
-    NaiveDatabase newRelationMap newConstantSet
-   where
-    newArity = length terms
-    newRelation = lookupRelation0 relationName db newArity (Set.singleton terms)
-    newRelationMap = Map.insert relationName newRelation relationMap
-    newConstantSet = Set.union constantSet $ Set.fromList terms
 
 data (DatalogDB db) => RuleContext db = RuleContext
   { __relation :: Relation
@@ -126,15 +127,7 @@ data (DatalogDB db) => RuleContext db = RuleContext
   , _db :: db
   }
 
--- | equivalent(Q,Q) :- . |
--- could be equivalent(Q, 3, 'zzz, Q, R)
--- terms = Var Q, Num 3, Sym zzz, Var Q, Var R
--- want to convert this to:
--- (need constants 3, 'zzz)
--- entries = [RuleElement] = (RuleElement 0), RuleElement Num 3, RuleElement Sym zzz, (RuleElement 0), (RuleElement 1)
--- variableNames = ["Q" "R"]
-
-digestHead :: forall db . (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
+digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
 digestHead db relation (Literal neg relationName terms) =
   RuleContext
     { __relation = relation
@@ -150,7 +143,7 @@ digestHead db relation (Literal neg relationName terms) =
     extractConstant :: RuleElement -> Maybe Constant
     extractConstant (RuleElementConstant constant) = Just constant
     extractConstant _ = Nothing
-digestBody :: forall db . (DatalogDB db) => Literal -> RuleContext db -> RuleContext db
+digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db
 digestBody (Literal neg subRelationName subTerms) context =
   context { 
     _variableNames = variableNames
@@ -173,11 +166,13 @@ digestBody (Literal neg subRelationName subTerms) context =
     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
@@ -186,7 +181,7 @@ headTermToElement _ constant = RuleElementConstant constant
 withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
 withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
 
-query :: NaiveDatabase -> Text -> Text
+query :: forall db . (DatalogDB db) => db -> Text -> Text
 query db qText =
   case parseDatalog qText of
     Right (Query texts literals) -> "#NYI"

haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs

@@ -233,7 +233,7 @@ spec = do
         `shouldBe` Set.empty
 
     it "can do basic queries" do
-      let db =
+      let db :: NaiveDatabase =
             NaiveDatabase.withFacts
               [ "parent(\"alice\", \"bob\")."
               , "parent(\"bob\", \"carol\")."