haskell-experiments/haskell-experiments.cabal

@@ -51,18 +51,21 @@ 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:   GHC2024
-  default-extensions:
-    OverloadedStrings 
-
 common warnings
     ghc-options: -Wall
 
 test-suite haskell-exps-test
     -- Import common warning flags.
-  import: warnings, commonSettings
+    import:           warnings
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
 
     -- The interface type and version of the test suite.
     type:             exitcode-stdio-1.0
@@ -74,18 +77,15 @@ test-suite haskell-exps-test
     main-is:          Main.hs
 
     -- Test dependencies.
-  build-depends:    base, containers, megaparsec, hspec, langfeatures, text
-  other-modules:    Test.OlogsSpec
-    Test.SimpleParserSpec
-    Test.ArithmeticParserSpec
-    Test.Datalog.DatalogParserSpec
+    build-depends:    base, containers, megaparsec, hspec, langfeatures
+    other-modules:    Test.OlogsSpec,
+      Test.SimpleParserSpec,
+      Test.ArithmeticParserSpec,
+      Test.Datalog.DatalogParserSpec,
       Test.Datalog.InMemoryDBSpec
-    Test.Datalog.NaiveQESpec
-    Test.Datalog.DigestedQuerySpec
-    Test.Utility.UtilitySpec
 
 library langfeatures
-  import: warnings, commonSettings
+  default-language: Haskell2010
   build-depends:   base, containers, megaparsec, parser-combinators, text
   hs-source-dirs:  src
   exposed-modules: Ologs
@@ -95,15 +95,13 @@ library langfeatures
     Datalog.InMemoryDB
     Datalog.Rules
     Datalog.DatalogDB
-    Datalog.NaiveQE
-    Datalog.QueryEngine
-    Datalog.DigestedQuery
-    Utility.Utility
+  ghc-options:     -Wall
+  default-extensions:
+    OverloadedStrings 
 
 executable haskell-experiments
-  import: warnings, commonSettings
+  default-language: Haskell2010
   build-depends:    base, containers
   main-is:          Main.hs
   hs-source-dirs:   src
 
-

haskell-experiments/src/ArithmeticParser.hs

@@ -1,3 +1,5 @@
+{-# 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
 
@@ -57,11 +57,9 @@ type RelationId = Text
 
 class DatalogDB db where
   emptyDB :: db
-  relationNames :: db -> [Text]
   lookupRelation :: db -> Text -> Maybe Relation
   insertRelation :: db -> Relation -> db
   addConstants :: db -> Set Constant -> db
-  allConstants :: db -> Set Constant
 
 lookupRelationArity :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation
 lookupRelationArity relationName db newArity tuples =
@@ -81,34 +79,3 @@ 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 fit - 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,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Datalog.DatalogParser where
 
 import Data.Void

haskell-experiments/src/Datalog/DigestedQuery.hs

@@ -1,59 +0,0 @@
-module Datalog.DigestedQuery where
-
-import Data.Text (Text)
-import Datalog.DatalogDB (Constant, DatalogDBException (..))
-import Datalog.DatalogParser
-import Control.Exception (throw)
-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 = 
-      length $ if null variables then allBoundVariables else variables,
-    conditions = extractCondition <$> literals
-  } where
-    allBoundVariables = nub $ variables ++ extractedVariables
-    extractedVariables :: [Text] =
-      nub $ concatMap extractVariablesSub literals
-    extractVariablesSub :: Literal -> [Text]
-    extractVariablesSub lit =
-      concatMap extractVariablesSubSub (arguments lit)
-    extractVariablesSubSub :: Term -> [Text]
-    extractVariablesSubSub (Var name) = [name]
-    extractVariablesSubSub _ = []
-    extractCondition :: Literal -> DigestedQueryCondition
-    extractCondition lit = DigestedQueryCondition {
-      __relation = predName lit,
-      _entries = extractEntry <$> arguments lit
-    }
-    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

@@ -1,5 +1,6 @@
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# LANGUAGE InstanceSigs #-}
@@ -8,7 +9,7 @@
 module Datalog.InMemoryDB where
 
 import Control.Exception.Base
-import Data.Map (Map, keys)
+import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -18,40 +19,55 @@ import Datalog.Rules
 import Datalog.DatalogDB
 
 data InMemoryDB = InMemoryDB
-  { _relations :: Map RelationId Relation
-  , _constants :: Set Constant
+  { relations :: Map RelationId Relation
+  , constants :: Set Constant
   } deriving (Show, Eq)
 
+
 instance DatalogDB InMemoryDB where
   emptyDB :: InMemoryDB
   emptyDB = InMemoryDB
-    { _relations = Map.empty
-    , _constants = Set.empty -- the Herbrand universe
+    { relations = Map.empty
+    , constants = Set.empty -- the Herbrand universe
     }
 
   lookupRelation :: InMemoryDB -> Text -> Maybe Relation
   lookupRelation db relationName =
-    Map.lookup relationName $ _relations db
+    Map.lookup relationName $ relations db
 
   insertRelation :: InMemoryDB -> Relation -> InMemoryDB
   insertRelation db relation =
     db {
-      _relations = Map.insert (_name relation) relation (_relations db)
+      relations = Map.insert (_name relation) relation (relations db)
     }
 
   addConstants :: InMemoryDB -> Set Constant -> InMemoryDB
   addConstants db newConstants =
     db {
-      _constants = Set.union newConstants (_constants db)
+      constants = Set.union newConstants (constants db)
     }
 
-  relationNames :: InMemoryDB -> [Text]
-  relationNames db = keys (_relations 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
 
-  allConstants :: InMemoryDB -> Set Constant
-  allConstants = _constants
+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 :: [Text] -> InMemoryDB
+withFacts :: DatalogDB db => [Text] -> db
 withFacts =
   foldr (addFact . extractFact) emptyDB
  where
@@ -65,3 +81,9 @@ 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/src/Datalog/NaiveQE.hs

@@ -1,95 +0,0 @@
-{-# HLINT ignore "Redundant flip" #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# LANGUAGE BlockArguments #-}
-{-# HLINT ignore "Redundant flip" #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# LANGUAGE InstanceSigs #-}
-
-module Datalog.NaiveQE where
-import Datalog.QueryEngine
-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 Utility.Utility
-import Control.Monad(guard)
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Data.Functor ((<&>))
-
-data NaiveQE db = NaiveQE 
-  {
-    db :: db,
-    herbrand :: Map Text Relation
-  } deriving (Show, Eq)
-
-instance QueryEngine NaiveQE where
-  queryEngine :: (DatalogDB db) => db -> NaiveQE db
-  queryEngine db = NaiveQE { 
-    db = db,
-    herbrand = computeHerbrand db
-  }
-  query :: (DatalogDB db) => NaiveQE db -> 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
-
-type Facts = Map Text Relation
-type NewFacts = (Facts, Bool)
-
-computeHerbrand :: (DatalogDB db) => db -> Facts
-computeHerbrand db =
-  computeHerbrandSub initialFacts where
-    initialFacts :: Facts =
-      Map.fromList $ mapMaybe (\relationName -> do
-        relation <- lookupRelation db relationName
-        pure (relationName, relation)
-        ) allRelationNames
-    allRelationNames :: [Text] = relationNames db 
-    computeHerbrandSub :: Map Text Relation -> Map Text Relation
-    computeHerbrandSub facts = 
-      maybe facts computeHerbrandSub (updateFacts 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 = 
-      maybe newFacts (amalgamateRelationSub newFacts) $ lookupRelation db relationName
-    amalgamateRelationSub :: NewFacts -> Relation -> NewFacts
-    amalgamateRelationSub newFacts relation = 
-      foldr amalgamateRule newFacts (_rules relation) where
-      amalgamateRule :: RelationRule -> NewFacts -> NewFacts
-      amalgamateRule (RelationRule headVars bodyElements) newFacts  =
-        if stillChanged then
-          (updatedFacts, True)
-        else newFacts
-        where
-        (facts, wasChanged) = newFacts
-        latestRelation = facts Map.! _name relation
-        knownTuples :: Set [Constant] = _tuples latestRelation
-        extraTuples = do
-          varmap <- allMaps headVars (Set.toList $ allConstants db)
-          let tuple = (varmap Map.!) <$> headVars
-          guard $ not $ Set.member tuple knownTuples
-          let satisfied :: RuleBodyElement -> Bool
-              satisfied (RuleBodyElement subRelationId ruleElements) = 
-                let subRelation = facts Map.! subRelationId
-                    mappedTuple = ruleElements <&> \case
-                      RuleElementConstant constant -> constant
-                      RuleElementVariable index -> tuple !! index
-                in Set.member mappedTuple (_tuples subRelation)
-          guard $ all satisfied bodyElements
-          return tuple
-        stillChanged = wasChanged || not (null extraTuples)
-        updatedTuples = Set.union knownTuples $ Set.fromList extraTuples 
-        updatedFacts = Map.insert (_name relation) (
-          latestRelation { _tuples = updatedTuples }) facts
-

haskell-experiments/src/Datalog/QueryEngine.hs

@@ -1,16 +0,0 @@
-{-# 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 db
-  query :: (DatalogDB db) => qe db -> Text -> Text
-
-

haskell-experiments/src/Datalog/Rules.hs

@@ -1,5 +1,6 @@
 {-# HLINT ignore "Redundant flip" #-}
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
@@ -28,7 +29,7 @@ extractRule ruleText =
 appendRule :: Relation -> RelationRule -> Relation
 appendRule relation rule =
   relation {
-    _rules = rule : _rules relation
+    _rules = rule : (_rules relation)
   }
 
 toRuleBodyElement :: BodyConstraint -> RuleBodyElement
@@ -60,7 +61,7 @@ addRule (ruleHead, body) db  =
         , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
       }
 
-data RuleContext db = RuleContext
+data (DatalogDB db) => RuleContext db = RuleContext
   { __relation :: Relation
   , _variableNames :: [Text]
   , _headEntries :: [RuleElement]
@@ -69,7 +70,7 @@ data RuleContext db = RuleContext
   }
 
 digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
-digestHead db relation (Literal _ _ terms) =
+digestHead db relation (Literal neg relationName terms) =
   RuleContext
     { __relation = relation
     , _variableNames = variableNames
@@ -79,17 +80,17 @@ digestHead db relation (Literal _ _ 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 _ subRelationName subTerms) context =
+digestBody (Literal neg subRelationName subTerms) context =
   context { 
     _variableNames = variableNames
     , _bodyConstraints = newConstraint : constraints
-    , _db = insertRelation (addConstants db (Set.fromList extraConstants)) subRelation
+    , _db = insertRelation (addConstants db constants') subRelation
     }
  where
   db = _db context
@@ -100,6 +101,7 @@ digestBody (Literal _ 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/src/Utility/Utility.hs

@@ -1,21 +0,0 @@
-{-# HLINT ignore "Redundant flip" #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-module Utility.Utility where
-
-import Control.Exception.Base
-import Data.List
-import Data.Maybe
-import Data.Set qualified as Set
-import Data.Text (Text)
-import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
-import Datalog.DatalogDB
-
-import qualified Data.Map as Map
-
--- All functions from domain to codomain
-allMaps :: Ord a => [a] -> [b] -> [Map.Map a b]
-allMaps []     _   = [Map.empty]
-allMaps (x:xs) cod = [ Map.insert x y m | y <- cod, m <- allMaps xs cod ]

haskell-experiments/test/Main.hs

@@ -4,19 +4,14 @@ 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.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 "DigestedQuery" DigestedQuerySpec.spec
+

haskell-experiments/test/Test/ArithmeticParserSpec.hs

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

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

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

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

@@ -1,80 +0,0 @@
-{-# 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(..),
-        digestQuery )
-
-
-spec :: Spec
-spec = do
-  describe "DigestedQuery" $ do
-    it "can digest a basic query" $ do
-      digestQuery "?- parent(alice,X)." `shouldBe` DigestedQuery {
-          allBoundVariables = ["X"],
-          numSoughtVariables = 1,
-          conditions = [
-            DigestedQueryCondition {
-              __relation = "parent",
-              _entries = [
-                DigestedQueryEntryConstant $ Sym "alice",
-                DigestedQueryEntryVariable 0
-              ]
-            }
-          ]
-        }
-    it "can digest a query with all variables explicitly sought" $ do
-      digestQuery "?- knows(a,X), friend(X,Y) → X,Y." `shouldBe` DigestedQuery {
-          allBoundVariables = ["X", "Y"],
-          numSoughtVariables = 2,
-          conditions = [
-            DigestedQueryCondition {
-              __relation = "knows",
-              _entries = [
-                DigestedQueryEntryConstant $ Sym "a",
-                DigestedQueryEntryVariable 0
-              ]
-            },
-            DigestedQueryCondition {
-              __relation = "friend",
-              _entries = [
-                DigestedQueryEntryVariable 0,
-                DigestedQueryEntryVariable 1
-              ]
-            }
-          ]
-        }
-    it "can digest a query with unsought variables" $ do
-      digestQuery "?- edge(A,B), edge(B,C) → A,C ." `shouldBe` DigestedQuery {
-          allBoundVariables = ["A", "C", "B"],
-          numSoughtVariables = 2,
-          conditions = [
-            DigestedQueryCondition {
-              __relation = "edge",
-              _entries = [
-                DigestedQueryEntryVariable 0,
-                DigestedQueryEntryVariable 2
-              ]
-            },
-            DigestedQueryCondition {
-              __relation = "edge",
-              _entries = [
-                DigestedQueryEntryVariable 2,
-                DigestedQueryEntryVariable 1
-              ]
-            }
-          ]
-        }
-

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# HLINT ignore "Use const" #-}
 {-# HLINT ignore "Unused LANGUAGE pragma" #-}
 {-# HLINT ignore "Avoid lambda" #-}
@@ -20,7 +21,6 @@ import Datalog.InMemoryDB
 import Datalog.InMemoryDB qualified as InMemoryDB
 import Test.Hspec
 import Datalog.DatalogDB
-import Data.Text
 
 spec :: Spec
 spec = do
@@ -31,16 +31,15 @@ spec = do
               [ "parent(\"alice\", \"bob\")."
               , "parent(\"bob\", \"carol\")."
               ]
-      allConstants db
+      constants db
         `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
-      _relations db
+      relations db
         `shouldBe` Map.fromList
           [
             ( "parent"
             , Relation "parent" 2 (Set.fromList $ Sym <<$>> [["alice", "bob"], ["bob", "carol"]]) []
             )
           ]
-      relationNames db `shouldBe` [ "parent" ]
     it "can ingest facts and rules" do
       let db =
             InMemoryDB.withFactsAndRules
@@ -56,20 +55,36 @@ spec = do
               , _arity = 2
               , _tuples =
                   Set.fromList $
-                    Sym <<$>> [["alice", "bob"], ["bob", "carol"]]
+                    map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]
               , _rules = []
               }
           ancestorRule = RelationRule
               { headVariables = ["X", "Y", "Z"]
               , bodyElements =
-                  [ ruleBody "parent"   [0, 2]
-                  , ruleBody "ancestor" [2, 1]
+                  [ RuleBodyElement
+                      { _subRelationId = "parent"
+                      , _ruleElements =
+                          [ RuleElementVariable 0
+                          , RuleElementVariable 2
+                          ]
+                      }
+                  , RuleBodyElement
+                      { _subRelationId = "ancestor"
+                      , _ruleElements =
+                          [ RuleElementVariable 2
+                          , RuleElementVariable 1
+                          ]
+                      }
                   ]
               }
           ancestorRule2 = RelationRule
               { headVariables = ["X", "Y"]
               , bodyElements =
-                  [ ruleBody "parent" [0, 1] ]
+                  [ RuleBodyElement
+                      { _subRelationId = "parent"
+                      , _ruleElements = [RuleElementVariable 0, RuleElementVariable 1]
+                      }
+                  ]
               }
           ancestorRelation =
             Relation
@@ -79,15 +94,14 @@ spec = do
               , _rules = [ancestorRule, ancestorRule2]
               }
 
-      allConstants db
+      constants db
         `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
 
-      _relations db
+      relations db
         `shouldBe` Map.fromList
           [ ("ancestor", ancestorRelation)
           , ("parent", parentRelation)
           ]
-      Set.fromList (relationNames db) `shouldBe` Set.fromList [ "parent", "ancestor" ]
 
     it "can ingest facts and rules with constants" do
       let db =
@@ -106,12 +120,11 @@ spec = do
               , _tuples = Set.empty
               , _rules = [ancestorRule]
               }
-      _relations db
+      relations db
         `shouldBe` Map.singleton "ancestor" ancestorRelation
 
-      allConstants db
+      constants db
         `shouldBe` Set.fromList (Sym <$> ["patriarch"])
-      Set.fromList (relationNames db) `shouldBe` Set.fromList [ "ancestor" ]
 
     it "can ingest facts and rules with duplicate head entries" do
       let db =
@@ -130,12 +143,35 @@ spec = do
               , _tuples = Set.empty
               , _rules = [equivalentRule]
               }
-      _relations db
+      relations db
         `shouldBe` Map.singleton "equivalent" equivalentRelation
 
-      allConstants db
+      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
-      relationNames db `shouldBe` [ "equivalent" ]
 
     it "can ingest a theory of equivalence relations" do
       let db =
@@ -154,14 +190,33 @@ spec = do
             RelationRule
               { headVariables = ["R", "Q"]
               , bodyElements =
-                  [ ruleBody "equivalent" [1, 0] ]
+                  [ RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 1
+                          , RuleElementVariable 0
+                          ]
+                      }
+                  ]
               }
           rule3 =
             RelationRule
               { headVariables = ["Q", "S", "R"]
               , bodyElements =
-                  [ ruleBody "equivalent" [0, 2]
-                  , ruleBody "equivalent" [2, 1]
+                  [ RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 0
+                          , RuleElementVariable 2
+                          ]
+                      }
+                  , RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 2
+                          , RuleElementVariable 1
+                          ]
+                      }
                   ]
               }
           equivalentRelation =
@@ -171,23 +226,26 @@ spec = do
               , _tuples = Set.empty
               , _rules = [rule1, rule2, rule3]
               }
-      _relations db
+      relations db
         `shouldBe` Map.singleton "equivalent" equivalentRelation
 
-      allConstants db
+      constants db
         `shouldBe` Set.empty
-      Set.fromList (relationNames db) `shouldBe` Set.fromList [ "equivalent" ]
+
+    it "can do basic queries" do
+      let db :: InMemoryDB =
+            InMemoryDB.withFacts
+              [ "parent(\"alice\", \"bob\")."
+              , "parent(\"bob\", \"carol\")."
+              ]
+      query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'
 
 (<<$>>) :: (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
-
-ruleBody :: Text -> [Int] -> RuleBodyElement
-ruleBody subRelationId indices =
-  RuleBodyElement
-    { _subRelationId = subRelationId
-    , _ruleElements =
-      RuleElementVariable <$> indices
-    }

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

@@ -1,32 +0,0 @@
-{-# 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
-import Datalog.InMemoryDB (InMemoryDB)
-import qualified Datalog.InMemoryDB as InMemoryDB
-import Datalog.QueryEngine (QueryEngine(query), queryEngine)
-import Datalog.NaiveQE
-
-spec :: Spec
-spec = do
-  describe "NaiveQESpec" do
-    it "can do basic queries" do
-      let db :: InMemoryDB =
-            InMemoryDB.withFacts
-              [ "parent(\"alice\", \"bob\")."
-              , "parent(\"bob\", \"carol\")."
-              ]
-          qe :: NaiveQE InMemoryDB = queryEngine db 
-      query qe "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'

haskell-experiments/test/Test/Utility/UtilitySpec.hs

@@ -1,35 +0,0 @@
-{-# 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.Utility.UtilitySpec where
-
-import Test.Hspec
-import Utility.Utility
-import qualified Data.Map as Map
-import Data.Map
-
-spec :: Spec
-spec = do
-  describe "UtilitySpec" do
-    it "..." $ do
-      allMaps @Int @Int [] [] `shouldBe` [Map.empty]
-      allMaps @Int @Int [] [1] `shouldBe` [Map.empty]
-      allMaps @Int @Int [1] [] `shouldBe` []
-      allMaps [1] [True] `shouldBe` [Map.singleton 1 True]
-      uncharacteristic <$> allMaps [1, 2, 3] [True, False] `shouldMatchList` [
-        [1,2,3], [1,2], [1,3], [1], [2, 3], [2], [3], []
-        ]
-
-uncharacteristic :: forall a . Map a Bool -> [a]
-uncharacteristic intmap = [ x | (x, v) <- toList intmap, v ]
-