initial DigestedQuery code with tests

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

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
+ 

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

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

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
+              ]
+            }
+          ]
+        }

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
 

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