diff --git a/haskell-experiments/src/Datalog/NaiveQE.hs b/haskell-experiments/src/Datalog/NaiveQE.hs index cae0044..6d1f1e8 100644 --- a/haskell-experiments/src/Datalog/NaiveQE.hs +++ b/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 = - Map.fromList $ catMaybes $ relationNames db <&> (\relationName -> do + initialFacts :: Facts = + Map.fromList $ mapMaybe (\relationName -> do relation <- lookupRelation db relationName - pure (relationName, relation)) - updateFacts :: Map Text Relation -> Maybe (Map Text Relation) - updateFacts facts = Nothing -- Just facts + pure (relationName, relation) + ) allRelationNames + 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 - Just moreFacts -> computeHerbrandSub moreFacts - Nothing -> facts + maybe facts computeHerbrandSub (updateFacts facts) + allRelationNames :: [Text] = relationNames db