basic API for query engines

Reviewed-on: #1

haskell-experiments/haskell-experiments.cabal

@@ -51,41 +51,39 @@ extra-doc-files:    CHANGELOG.md
 -- Extra source files to be distributed with the package, such as examples, or a tutorial module.
 -- extra-source-files:
 
+common commonSettings
+  -- Base language which the package is written in.
+  default-language: Haskell2010
+  default-extensions:
+    OverloadedStrings 
+
 common warnings
     ghc-options: -Wall
 
 test-suite haskell-exps-test
-    -- Import common warning flags.
+  -- Import common warning flags.
-    import:           warnings
+  import: warnings, commonSettings
 
-    -- Base language which the package is written in.
+  -- The interface type and version of the test suite.
-    default-language: Haskell2010
+  type:             exitcode-stdio-1.0
 
-    -- Modules included in this executable, other than Main.
+  -- Directories containing source files.
-    -- other-modules:
+  hs-source-dirs:   test
 
-    -- LANGUAGE extensions used by modules in this package.
+  -- The entrypoint to the test suite.
-    -- other-extensions:
+  main-is:          Main.hs
 
-    -- The interface type and version of the test suite.
+  -- Test dependencies.
-    type:             exitcode-stdio-1.0
+  build-depends:    base, containers, megaparsec, hspec, langfeatures, text
-
+  other-modules:    Test.OlogsSpec
-    -- Directories containing source files.
+    Test.SimpleParserSpec
-    hs-source-dirs:   test
+    Test.ArithmeticParserSpec
-
+    Test.Datalog.DatalogParserSpec
-    -- The entrypoint to the test suite.
+    Test.Datalog.InMemoryDBSpec
-    main-is:          Main.hs
+    Test.Datalog.NaiveQESpec
-
-    -- Test dependencies.
-    build-depends:    base, containers, megaparsec, hspec, langfeatures
-    other-modules:    Test.OlogsSpec,
-      Test.SimpleParserSpec,
-      Test.ArithmeticParserSpec,
-      Test.Datalog.DatalogParserSpec,
-      Test.Datalog.InMemoryDBSpec
 
 library langfeatures
-  default-language: Haskell2010
+  import: warnings, commonSettings
   build-depends:   base, containers, megaparsec, parser-combinators, text
   hs-source-dirs:  src
   exposed-modules: Ologs
@@ -95,13 +93,13 @@ library langfeatures
     Datalog.InMemoryDB
     Datalog.Rules
     Datalog.DatalogDB
-  ghc-options:     -Wall
+    Datalog.NaiveQE
-  default-extensions:
+    Datalog.QueryEngine
-    OverloadedStrings 
 
 executable haskell-experiments
-  default-language: Haskell2010
+  import: warnings, commonSettings
   build-depends:    base, containers
   main-is:          Main.hs
   hs-source-dirs:   src
 
+

haskell-experiments/src/ArithmeticParser.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module ArithmeticParser where
 
 import Text.Megaparsec

haskell-experiments/src/Datalog/DatalogDB.hs

@@ -1,8 +1,8 @@
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# LANGUAGE BlockArguments #-}
 
 module Datalog.DatalogDB where
 
@@ -79,3 +79,34 @@ addFact (Literal neg relationName terms) db =
   newRelation = lookupRelationArity relationName db newArity (Set.singleton terms)
   extraConstants = Set.fromList terms
 
+-- the world isn't quite ready for these, as the 'update relation' pattern doesn't fir - maybe use a lens?
+-- lookupRelation00 :: DatalogDB db => 
+--   Text -> db -> Int -> (Relation -> Relation) -> db
+-- lookupRelation00 relationName db newArity update =
+--   insertRelation db (update newRelation) 
+--     where
+--     newRelation = case lookupRelation db relationName of
+--       Nothing -> Relation relationName newArity Set.empty []
+--       Just relation ->
+--         if _arity relation == newArity then
+--             relation
+--           else throw $ BadArityException relationName newArity
+
+-- lookupRelation000 :: DatalogDB db => 
+--   Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
+-- lookupRelation000 relationName db newArity tuples update =
+--   lookupRelation00 relationName db newArity \relation ->
+--     update relation { 
+--       _tuples = Set.union tuples $ _tuples relation 
+--     }
+
+-- lookupRelationArity0 :: DatalogDB db => Text -> db -> Int -> (Relation -> Relation) -> db
+-- lookupRelationArity0 relationName db newArity update =
+--   insertRelation db (update newRelation) 
+--     where
+--     newRelation = case lookupRelation db relationName of
+--       Nothing -> Relation relationName newArity Set.empty []
+--       Just relation ->
+--         if _arity relation == newArity then relation
+--         else throw $ BadArityException relationName newArity
+

haskell-experiments/src/Datalog/DatalogParser.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Datalog.DatalogParser where
 
 import Data.Void

haskell-experiments/src/Datalog/InMemoryDB.hs

@@ -1,6 +1,5 @@
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# LANGUAGE InstanceSigs #-}
@@ -23,7 +22,6 @@ data InMemoryDB = InMemoryDB
   , constants :: Set Constant
   } deriving (Show, Eq)
 
-
 instance DatalogDB InMemoryDB where
   emptyDB :: InMemoryDB
   emptyDB = InMemoryDB
@@ -47,26 +45,6 @@ instance DatalogDB InMemoryDB where
       constants = Set.union newConstants (constants db)
     }
 
-lookupRelation00 :: DatalogDB db => 
-  Text -> db -> Int -> (Relation -> Relation) -> db
-lookupRelation00 relationName db newArity update =
-  insertRelation db (update newRelation) 
-    where
-    newRelation = case lookupRelation db relationName of
-      Nothing -> Relation relationName newArity Set.empty []
-      Just relation ->
-        if _arity relation == newArity then
-            relation
-          else throw $ BadArityException relationName newArity
-
-lookupRelation000 :: DatalogDB db => 
-  Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
-lookupRelation000 relationName db newArity tuples update =
-  lookupRelation00 relationName db newArity \relation ->
-    update relation { 
-      _tuples = Set.union tuples $ _tuples relation 
-    }
-
 withFacts :: DatalogDB db => [Text] -> db
 withFacts =
   foldr (addFact . extractFact) emptyDB

haskell-experiments/src/Datalog/NaiveQE.hs

@@ -0,0 +1,35 @@
+{-# 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 Datalog.DatalogDB
+import Datalog.DatalogParser
+import Control.Exception
+
+data NaiveQE = NaiveQE 
+  {
+
+  } deriving (Show, Eq)
+
+instance QueryEngine NaiveQE where
+  queryEngine :: (DatalogDB db) => db -> NaiveQE
+  queryEngine db = NaiveQE { }
+  query :: NaiveQE -> Text -> Text
+  query qe queryText =
+    case parseDatalog queryText of
+      Right (Query texts literals) -> "#NYI"
+      Right otherStatement -> throw $ NonQueryException queryText otherStatement
+      Left ex -> throw $ CannotParseStatementException queryText ex
+

haskell-experiments/src/Datalog/QueryEngine.hs

@@ -0,0 +1,16 @@
+{-# HLINT ignore "Redundant flip" #-}
+-- {-# LANGUAGE ImportQualifiedPost #-}
+-- {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# LANGUAGE BlockArguments #-}
+
+module Datalog.QueryEngine where
+import Datalog.DatalogDB
+import Data.Text
+
+class QueryEngine qe where
+  queryEngine :: (DatalogDB db) => db -> qe
+  query :: qe -> Text -> Text
+
+

haskell-experiments/src/Datalog/Rules.hs

@@ -1,6 +1,5 @@
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
@@ -29,7 +28,7 @@ extractRule ruleText =
 appendRule :: Relation -> RelationRule -> Relation
 appendRule relation rule =
   relation {
-    _rules = rule : (_rules relation)
+    _rules = rule : _rules relation
   }
 
 toRuleBodyElement :: BodyConstraint -> RuleBodyElement
@@ -70,7 +69,7 @@ data (DatalogDB db) => RuleContext db = RuleContext
   }
 
 digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
-digestHead db relation (Literal neg relationName terms) =
+digestHead db relation (Literal _ _ terms) =
   RuleContext
     { __relation = relation
     , _variableNames = variableNames
@@ -80,17 +79,17 @@ digestHead db relation (Literal neg relationName terms) =
     }
  where
   variableNames = nub $ extractVariableNames terms
-  entries' = nub $ (headTermToElement variableNames) <$> terms
+  entries' = nub $ headTermToElement variableNames <$> terms
   extraConstants = Set.fromList $ mapMaybe extractConstant entries' where
     extractConstant :: RuleElement -> Maybe Constant
     extractConstant (RuleElementConstant constant) = Just constant
     extractConstant _ = Nothing
 digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db
-digestBody (Literal neg subRelationName subTerms) context =
+digestBody (Literal _ subRelationName subTerms) context =
   context { 
     _variableNames = variableNames
     , _bodyConstraints = newConstraint : constraints
-    , _db = insertRelation (addConstants db constants') subRelation
+    , _db = insertRelation (addConstants db (Set.fromList extraConstants)) subRelation
     }
  where
   db = _db context
@@ -101,7 +100,6 @@ digestBody (Literal neg subRelationName subTerms) context =
     constantFromTerm :: Term -> Maybe Constant
     constantFromTerm (Var _) = Nothing
     constantFromTerm constant = Just constant
-  constants' = Set.fromList extraConstants
   constraints = _bodyConstraints context
   newConstraint = BodyConstraint subRelation subRuleElements where
     subRuleElements = toRuleElement <$> subTerms

haskell-experiments/test/Main.hs

@@ -6,6 +6,7 @@ import qualified Test.SimpleParserSpec as SimpleParserSpec
 import qualified Test.ArithmeticParserSpec as ArithmeticParserSpec
 import qualified Test.Datalog.DatalogParserSpec as DatalogParserSpec
 import qualified Test.Datalog.InMemoryDBSpec as InMemoryDBSpec
+import qualified Test.Datalog.NaiveQESpec as NaiveQESpec
 
 main :: IO ()
 main = hspec $ do
@@ -14,4 +15,5 @@ main = hspec $ do
     describe "ArithmeticParser" ArithmeticParserSpec.spec
     describe "DatalogParser" DatalogParserSpec.spec
     describe "InMemoryDB" InMemoryDBSpec.spec
+    describe "NaiveQE" NaiveQESpec.spec
 

haskell-experiments/test/Test/ArithmeticParserSpec.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# HLINT ignore "Use const" #-}

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# HLINT ignore "Use const" #-}

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# HLINT ignore "Use const" #-}
 {-# HLINT ignore "Unused LANGUAGE pragma" #-}
 {-# HLINT ignore "Avoid lambda" #-}
@@ -21,6 +20,7 @@ import Datalog.InMemoryDB
 import Datalog.InMemoryDB qualified as InMemoryDB
 import Test.Hspec
 import Datalog.DatalogDB
+import Data.Text
 
 spec :: Spec
 spec = do
@@ -55,36 +55,20 @@ spec = do
               , _arity = 2
               , _tuples =
                   Set.fromList $
-                    map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]
+                    Sym <<$>> [["alice", "bob"], ["bob", "carol"]]
               , _rules = []
               }
           ancestorRule = RelationRule
               { headVariables = ["X", "Y", "Z"]
               , bodyElements =
-                  [ RuleBodyElement
+                  [ ruleBody "parent"   [0, 2]
-                      { _subRelationId = "parent"
+                  , ruleBody "ancestor" [2, 1]
-                      , _ruleElements =
-                          [ RuleElementVariable 0
-                          , RuleElementVariable 2
-                          ]
-                      }
-                  , RuleBodyElement
-                      { _subRelationId = "ancestor"
-                      , _ruleElements =
-                          [ RuleElementVariable 2
-                          , RuleElementVariable 1
-                          ]
-                      }
                   ]
               }
           ancestorRule2 = RelationRule
               { headVariables = ["X", "Y"]
               , bodyElements =
-                  [ RuleBodyElement
+                  [ ruleBody "parent" [0, 1] ]
-                      { _subRelationId = "parent"
-                      , _ruleElements = [RuleElementVariable 0, RuleElementVariable 1]
-                      }
-                  ]
               }
           ancestorRelation =
             Relation
@@ -149,30 +133,6 @@ spec = do
       constants db
         `shouldBe` Set.empty
 
-    it "can ingest facts and rules with duplicate head entries" do
-      let db =
-            InMemoryDB.withFactsAndRules
-              []
-              ["equivalent(Q,Q) :- ."]
-          rule1 =
-            RelationRule
-              { headVariables = ["Q"]
-              , bodyElements = []
-              }
-
-          equivalentRelation =
-            Relation
-              { _arity = 2
-              , _name = "equivalent"
-              , _tuples = Set.empty
-              , _rules = [rule1]
-              }
-      relations db
-        `shouldBe` Map.singleton "equivalent" equivalentRelation
-
-      constants db
-        `shouldBe` Set.empty
-
     it "can ingest a theory of equivalence relations" do
       let db =
             InMemoryDB.withFactsAndRules
@@ -190,33 +150,14 @@ spec = do
             RelationRule
               { headVariables = ["R", "Q"]
               , bodyElements =
-                  [ RuleBodyElement
+                  [ ruleBody "equivalent" [1, 0] ]
-                      { _subRelationId = "equivalent"
-                      , _ruleElements =
-                          [ RuleElementVariable 1
-                          , RuleElementVariable 0
-                          ]
-                      }
-                  ]
               }
           rule3 =
             RelationRule
               { headVariables = ["Q", "S", "R"]
               , bodyElements =
-                  [ RuleBodyElement
+                  [ ruleBody "equivalent" [0, 2]
-                      { _subRelationId = "equivalent"
+                  , ruleBody "equivalent" [2, 1]
-                      , _ruleElements =
-                          [ RuleElementVariable 0
-                          , RuleElementVariable 2
-                          ]
-                      }
-                  , RuleBodyElement
-                      { _subRelationId = "equivalent"
-                      , _ruleElements =
-                          [ RuleElementVariable 2
-                          , RuleElementVariable 1
-                          ]
-                      }
                   ]
               }
           equivalentRelation =
@@ -249,3 +190,11 @@ spec = do
 -- (<<<$>>>) :: (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
+
+ruleBody :: Text -> [Int] -> RuleBodyElement
+ruleBody subRelationId indices =
+  RuleBodyElement
+    { _subRelationId = subRelationId
+    , _ruleElements =
+      RuleElementVariable <$> indices
+    }

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

@@ -0,0 +1,22 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# HLINT ignore "Use const" #-}
+{-# HLINT ignore "Unused LANGUAGE pragma" #-}
+{-# HLINT ignore "Avoid lambda" #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+module Test.Datalog.NaiveQESpec where
+
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "NaiveQESpec" do
+    it "..." $ do
+      1 `shouldBe` 1