From 42c992428a9552315797af6148c1c0d42754dc6f Mon Sep 17 00:00:00 2001 From: Felix Dilke Date: Wed, 11 Feb 2026 17:11:19 +0000 Subject: [PATCH] initial DigestedQuery code with tests --- haskell-experiments/haskell-experiments.cabal | 2 + .../src/Datalog/DigestedQuery.hs | 67 +++++++++++++++++++ haskell-experiments/src/Datalog/InMemoryDB.hs | 6 -- haskell-experiments/test/Main.hs | 6 +- .../test/Test/Datalog/DigestedQuerySpec.hs | 33 +++++++++ .../test/Test/Datalog/InMemoryDBSpec.hs | 4 -- .../test/Test/Datalog/NaiveQESpec.hs | 3 - 7 files changed, 106 insertions(+), 15 deletions(-) create mode 100644 haskell-experiments/src/Datalog/DigestedQuery.hs create mode 100644 haskell-experiments/test/Test/Datalog/DigestedQuerySpec.hs diff --git a/haskell-experiments/haskell-experiments.cabal b/haskell-experiments/haskell-experiments.cabal index 999914f..2b66519 100644 --- a/haskell-experiments/haskell-experiments.cabal +++ b/haskell-experiments/haskell-experiments.cabal @@ -81,6 +81,7 @@ test-suite haskell-exps-test Test.Datalog.DatalogParserSpec Test.Datalog.InMemoryDBSpec Test.Datalog.NaiveQESpec + Test.Datalog.DigestedQuerySpec Test.Utility.UtilitySpec library langfeatures @@ -96,6 +97,7 @@ library langfeatures Datalog.DatalogDB Datalog.NaiveQE Datalog.QueryEngine + Datalog.DigestedQuery Utility.Utility executable haskell-experiments diff --git a/haskell-experiments/src/Datalog/DigestedQuery.hs b/haskell-experiments/src/Datalog/DigestedQuery.hs new file mode 100644 index 0000000..ee6ce3c --- /dev/null +++ b/haskell-experiments/src/Datalog/DigestedQuery.hs @@ -0,0 +1,67 @@ +module Datalog.DigestedQuery where + +import Data.Void +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Control.Monad (void) +import Data.Functor (($>)) +import Datalog.DatalogDB (Relation, Constant, DatalogDBException (..)) +import Datalog.DatalogParser +import Control.Exception (throw) +import GHC.TypeError (ErrorMessage(Text)) +import Data.List (nub, elemIndex) + +data DigestedQuery = DigestedQuery { + allBoundVariables :: [Text], + numSoughtVariables :: Int, + conditions :: [DigestedQueryCondition] +} deriving (Show, Eq, Ord) + +data DigestedQueryCondition = DigestedQueryCondition { + __relation :: Text, + _entries :: [DigestedQueryEntry] +} deriving (Show, Eq, Ord) + +data DigestedQueryEntry = + DigestedQueryEntryConstant Constant | + DigestedQueryEntryVariable Int + deriving (Show, Eq, Ord) + +digestQuery :: Text -> DigestedQuery +digestQuery queryText = + case parseDatalog queryText of + Right (Query variables literals) -> digestQuerySub variables literals + Right statement0 -> throw $ NonQueryException "cannot digest non-query" statement0 + Left ex -> throw ex + +digestQuerySub :: [Text] -> [Literal] -> DigestedQuery +digestQuerySub variables literals = + DigestedQuery { + allBoundVariables = allBoundVariables, + numSoughtVariables = + if (null variables) then (length allBoundVariables) else (length variables), + conditions = extractCondition <$> literals + } where + allBoundVariables = nub $ variables ++ extractedVariables + extractedVariables :: [Text] = + nub $ concatMap extractVariablesSub literals + extractVariablesSub :: Literal -> [Text] + extractVariablesSub literal = + concatMap extractVariablesSubSub (arguments literal) + extractVariablesSubSub :: Term -> [Text] + extractVariablesSubSub (Var name) = [name] + extractVariablesSubSub _ = [] + extractCondition :: Literal -> DigestedQueryCondition + extractCondition literal = DigestedQueryCondition { + __relation = predName literal, + _entries = extractEntry <$> (arguments literal) + } + extractEntry :: Term -> DigestedQueryEntry + extractEntry (Var varName) = case elemIndex varName allBoundVariables of + Just index -> DigestedQueryEntryVariable index + Nothing -> throw $ VariableLookupException varName allBoundVariables + extractEntry constant = DigestedQueryEntryConstant constant + \ No newline at end of file diff --git a/haskell-experiments/src/Datalog/InMemoryDB.hs b/haskell-experiments/src/Datalog/InMemoryDB.hs index 4be8c30..980fe85 100644 --- a/haskell-experiments/src/Datalog/InMemoryDB.hs +++ b/haskell-experiments/src/Datalog/InMemoryDB.hs @@ -65,9 +65,3 @@ withFacts = withFactsAndRules :: [Text] -> [Text] -> InMemoryDB withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) --- query :: forall db . (DatalogDB db) => db -> Text -> Text --- query db qText = --- case parseDatalog qText of --- Right (Query texts literals) -> "#NYI" --- Right otherStatement -> throw $ NonQueryException qText otherStatement --- Left ex -> throw $ CannotParseStatementException qText ex diff --git a/haskell-experiments/test/Main.hs b/haskell-experiments/test/Main.hs index 56ed89f..81dde6a 100644 --- a/haskell-experiments/test/Main.hs +++ b/haskell-experiments/test/Main.hs @@ -4,17 +4,19 @@ import Test.Hspec import qualified Test.OlogsSpec as Ologs import qualified Test.SimpleParserSpec as SimpleParserSpec import qualified Test.ArithmeticParserSpec as ArithmeticParserSpec +import qualified Test.Utility.UtilitySpec as UtilitySpec import qualified Test.Datalog.DatalogParserSpec as DatalogParserSpec import qualified Test.Datalog.InMemoryDBSpec as InMemoryDBSpec import qualified Test.Datalog.NaiveQESpec as NaiveQESpec -import qualified Test.Utility.UtilitySpec as UtilitySpec +import qualified Test.Datalog.DigestedQuerySpec as DigestedQuerySpec main :: IO () main = hspec $ do + describe "Utility" UtilitySpec.spec describe "Ologs" Ologs.spec describe "SimpleParser" SimpleParserSpec.spec describe "ArithmeticParser" ArithmeticParserSpec.spec describe "DatalogParser" DatalogParserSpec.spec describe "InMemoryDB" InMemoryDBSpec.spec describe "NaiveQE" NaiveQESpec.spec - describe "Utility" UtilitySpec.spec + describe "DigestedQuery" DigestedQuerySpec.spec diff --git a/haskell-experiments/test/Test/Datalog/DigestedQuerySpec.hs b/haskell-experiments/test/Test/Datalog/DigestedQuerySpec.hs new file mode 100644 index 0000000..af59af1 --- /dev/null +++ b/haskell-experiments/test/Test/Datalog/DigestedQuerySpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# HLINT ignore "Use const" #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# HLINT ignore "Avoid lambda" #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Datalog.DigestedQuerySpec where + +import Test.Hspec +import Datalog.DatalogParser +import Datalog.DigestedQuery (DigestedQuery(..), DigestedQueryCondition(..), DigestedQueryEntry(..)) +import Datalog.DigestedQuery (digestQuery) + +spec :: Spec +spec = do + describe "DigestedQuery" $ do + it "can digest basic queries" $ do + digestQuery "?- parent(alice,X)." `shouldBe` DigestedQuery { + allBoundVariables = ["X"], + numSoughtVariables = 1, + conditions = [ + DigestedQueryCondition { + __relation = "parent", + _entries = [ + DigestedQueryEntryConstant $ Sym "alice", + DigestedQueryEntryVariable 0 + ] + } + ] + } diff --git a/haskell-experiments/test/Test/Datalog/InMemoryDBSpec.hs b/haskell-experiments/test/Test/Datalog/InMemoryDBSpec.hs index 88981ef..24c431f 100644 --- a/haskell-experiments/test/Test/Datalog/InMemoryDBSpec.hs +++ b/haskell-experiments/test/Test/Datalog/InMemoryDBSpec.hs @@ -181,10 +181,6 @@ spec = do (<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b) (<<$>>) = fmap fmap fmap --- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (f2 (a -> b)) -> f1 (f2 (f3 a -> f3 b)) --- (<<<$>>>) :: Functor f => (a1 -> b) -> (a2 -> a1) -> f a2 -> f b --- (<<<$>>>) :: (Functor f1, Functor f2) => (a1 -> a2 -> b) -> f1 a1 -> f1 (f2 a2 -> f2 b) --- (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => f1 (a -> b) -> f1 (f2 (f3 a) -> f2 (f3 b)) (<<<$>>>) :: (Functor f1, Functor f2, Functor f3) => (a -> b) -> f1 (f2 (f3 a)) -> f1 (f2 (f3 b)) (<<<$>>>) = fmap fmap fmap fmap fmap fmap fmap fmap diff --git a/haskell-experiments/test/Test/Datalog/NaiveQESpec.hs b/haskell-experiments/test/Test/Datalog/NaiveQESpec.hs index 3384085..726ed44 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveQESpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveQESpec.hs @@ -25,9 +25,6 @@ import Datalog.NaiveQE spec :: Spec spec = do describe "NaiveQESpec" do - it "..." $ do - 1 `shouldBe` 1 - it "can do basic queries" do let db :: InMemoryDB = InMemoryDB.withFacts