herbrand continued

haskell-experiments/src/Datalog/NaiveQE.hs

@@ -1,26 +1,21 @@
 {-# HLINT ignore "Redundant flip" #-}
--- {-# LANGUAGE ImportQualifiedPost #-}
--- {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# LANGUAGE BlockArguments #-}
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE BlockArguments #-}
 
 module Datalog.NaiveQE where
 import Datalog.QueryEngine
-import Data.Text
+import Data.Text (Text)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Datalog.DatalogDB
 import Datalog.DatalogParser
 import Control.Exception
 import Data.Maybe
-import Data.Functor ((<&>))
 
 data (DatalogDB db) => NaiveQE db = NaiveQE 
   {
@@ -41,18 +36,25 @@ instance QueryEngine NaiveQE where
       Right otherStatement -> throw $ NonQueryException queryText otherStatement
       Left ex -> throw $ CannotParseStatementException queryText ex
 
-computeHerbrand :: (DatalogDB db) => db -> Map Text Relation
+type Facts = Map Text Relation
+type NewFacts = (Facts, Bool)
+
+computeHerbrand :: (DatalogDB db) => db -> Facts
 computeHerbrand db =
   computeHerbrandSub initialFacts where
-    initialFacts :: Map Text Relation =
+    initialFacts :: Facts =
-      Map.fromList $ catMaybes $ relationNames db <&> (\relationName -> do
+      Map.fromList $ mapMaybe (\relationName -> do
         relation <- lookupRelation db relationName
-        pure (relationName, relation))
+        pure (relationName, relation)
-    updateFacts :: Map Text Relation -> Maybe (Map Text Relation)
+        ) allRelationNames
-    updateFacts facts = Nothing -- Just facts
+    updateFacts :: Facts -> Maybe Facts
+    updateFacts facts =
+      if changed then Just newFacts else Nothing where
+      (newFacts, changed) = foldr amalgamateRelation (facts, False) allRelationNames
+    amalgamateRelation :: Text -> NewFacts -> NewFacts
+    amalgamateRelation relationName newFacts = newFacts
     computeHerbrandSub :: Map Text Relation -> Map Text Relation
     computeHerbrandSub facts = 
-      case updateFacts facts of
+      maybe facts computeHerbrandSub (updateFacts facts)
-        Just moreFacts -> computeHerbrandSub moreFacts
+    allRelationNames :: [Text] = relationNames db 
-        Nothing -> facts