fairly drastic restructuring

haskell-experiments/src/Datalog/DatalogDB.hs

@@ -8,16 +8,54 @@ module Datalog.DatalogDB where
 
 import Control.Exception.Base
 import Data.List
-import Data.Map (Map)
-import Data.Map qualified as Map
 import Data.Maybe
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
-import Data.Void
-import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
+import Datalog.DatalogParser (Literal (..), Term (..), Statement)
 import Text.Megaparsec (ParseErrorBundle)
-import Datalog.Rules
+import Data.Void
+
+data Relation = Relation
+  { _name :: RelationId
+  , _arity :: Int
+  , _tuples :: Set [Constant]
+  , _rules :: [RelationRule]
+  }
+  deriving (Show, Eq)
+
+data RelationRule = RelationRule
+  { headVariables :: [Text]
+  , bodyElements :: [RuleBodyElement]
+  }
+  deriving (Show, Eq)
+
+data RuleBodyElement = RuleBodyElement
+  { _subRelationId :: RelationId
+  , _ruleElements :: [RuleElement]
+  }
+  deriving (Show, Eq)
+
+data RuleElement -- entry occurring in a head or body relation - constant or variable
+  = RuleElementConstant Constant
+  | RuleElementVariable Int
+  deriving (Show, Eq)
+
+data DatalogDBException
+  = CannotParseStatementException Text (ParseErrorBundle Text Void)
+  | NonFactException Text Statement
+  | NonRuleException Text Statement
+  | NonQueryException Text Statement
+  | BadArityException Text Int
+  | VariableLookupException Text [Text]
+  | UnexpectedConstantException Constant
+  deriving (Show)
+
+instance Exception DatalogDBException
+
+-- Our constants will be the terms of the Datalog grammar - ints/variables/symbols
+type Constant = Term
+type RelationId = Text
 
 class DatalogDB db where
   emptyDB :: db
@@ -43,77 +81,3 @@ addFact (Literal neg relationName terms) db =
   newRelation = lookupRelationArity relationName db newArity (Set.singleton terms)
   extraConstants = Set.fromList terms
 
-addRule :: (DatalogDB db) => (Literal, [Literal]) -> db -> db
-addRule (ruleHead, body) db  =
-  insertRelation db' newRelation
-  where
-    relationName = predName ruleHead
-    terms = arguments ruleHead
-    newArity = length terms
-    relation = lookupRelationArity relationName db newArity Set.empty
-    context = digestHead db relation ruleHead
-    context' = foldr digestBody context body
-    db' = _db context'
-    newRelation = appendRule relation RelationRule { 
-        headVariables = _variableNames context'
-        , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
-      }
-
-data (DatalogDB db) => RuleContext db = RuleContext
-  { __relation :: Relation
-  , _variableNames :: [Text]
-  , _headEntries :: [RuleElement]
-  , _bodyConstraints :: [BodyConstraint]
-  , _db :: db
-  }
-
-digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
-digestHead db relation (Literal neg relationName terms) =
-  RuleContext
-    { __relation = relation
-    , _variableNames = variableNames
-    , _headEntries = entries'
-    , _bodyConstraints = []
-    , _db = insertRelation (addConstants db extraConstants) relation
-    }
- where
-  variableNames = nub $ extractVariableNames 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 =
-  context { 
-    _variableNames = variableNames
-    , _bodyConstraints = newConstraint : constraints
-    , _db = insertRelation (addConstants db constants') subRelation
-    }
- where
-  db = _db context
-  variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
-  newArity = length subTerms
-  subRelation = lookupRelationArity subRelationName (_db context) newArity Set.empty
-  extraConstants = mapMaybe constantFromTerm subTerms where
-    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
-    toRuleElement :: Term -> RuleElement
-    toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames
-    toRuleElement constant = RuleElementConstant constant
-
-lookupVariable :: Text -> [Text] -> Int
-lookupVariable varName variableNames = 
-  case elemIndex varName variableNames of
-      Just index -> index
-      Nothing -> throw $ VariableLookupException varName variableNames
-
-headTermToElement :: [Text] -> Term -> RuleElement
-headTermToElement variableNames (Var name) = 
-  RuleElementVariable $ lookupVariable name variableNames
-headTermToElement _ constant = RuleElementConstant constant

haskell-experiments/src/Datalog/Rules.hs

@@ -17,35 +17,7 @@ import Data.Text (Text)
 import Data.Void
 import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
 import Text.Megaparsec (ParseErrorBundle)
-
-data RuleElement -- entry occurring in a head or body relation - constant or variable
-  = RuleElementConstant Constant
-  | RuleElementVariable Int
-  deriving (Show, Eq)
-
-data RuleBodyElement = RuleBodyElement
-  { _subRelationId :: RelationId
-  , _ruleElements :: [RuleElement]
-  }
-  deriving (Show, Eq)
-
-data RelationRule = RelationRule
-  { headVariables :: [Text]
-  , bodyElements :: [RuleBodyElement]
-  }
-  deriving (Show, Eq)
-
-data Relation = Relation
-  { _name :: RelationId
-  , _arity :: Int
-  , _tuples :: Set [Constant]
-  , _rules :: [RelationRule]
-  }
-  deriving (Show, Eq)
-
--- Our constants will be the terms of the Datalog grammar - ints/variables/symbols
-type Constant = Term
-type RelationId = Text
+import Datalog.DatalogDB
 
 data BodyConstraint = BodyConstraint
   { _subRelation :: Relation
@@ -78,15 +50,78 @@ extractVariableNames = mapMaybe extractVariableName where
   extractVariableName (Var name) = Just name
   extractVariableName _ = Nothing
 
-data DatalogDBException
-  = CannotParseStatementException Text (ParseErrorBundle Text Void)
-  | NonFactException Text Statement
-  | NonRuleException Text Statement
-  | NonQueryException Text Statement
-  | BadArityException Text Int
-  | VariableLookupException Text [Text]
-  | UnexpectedConstantException Constant
-  deriving (Show)
+addRule :: (DatalogDB db) => (Literal, [Literal]) -> db -> db
+addRule (ruleHead, body) db  =
+  insertRelation db' newRelation
+  where
+    relationName = predName ruleHead
+    terms = arguments ruleHead
+    newArity = length terms
+    relation = lookupRelationArity relationName db newArity Set.empty
+    context = digestHead db relation ruleHead
+    context' = foldr digestBody context body
+    db' = _db context'
+    newRelation = appendRule relation RelationRule { 
+        headVariables = _variableNames context'
+        , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
+      }
 
-instance Exception DatalogDBException
+data (DatalogDB db) => RuleContext db = RuleContext
+  { __relation :: Relation
+  , _variableNames :: [Text]
+  , _headEntries :: [RuleElement]
+  , _bodyConstraints :: [BodyConstraint]
+  , _db :: db
+  }
+
+digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db
+digestHead db relation (Literal neg relationName terms) =
+  RuleContext
+    { __relation = relation
+    , _variableNames = variableNames
+    , _headEntries = entries'
+    , _bodyConstraints = []
+    , _db = insertRelation (addConstants db extraConstants) relation
+    }
+ where
+  variableNames = nub $ extractVariableNames 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 =
+  context { 
+    _variableNames = variableNames
+    , _bodyConstraints = newConstraint : constraints
+    , _db = insertRelation (addConstants db constants') subRelation
+    }
+ where
+  db = _db context
+  variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
+  newArity = length subTerms
+  subRelation = lookupRelationArity subRelationName (_db context) newArity Set.empty
+  extraConstants = mapMaybe constantFromTerm subTerms where
+    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
+    toRuleElement :: Term -> RuleElement
+    toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames
+    toRuleElement constant = RuleElementConstant constant
+
+lookupVariable :: Text -> [Text] -> Int
+lookupVariable varName variableNames = 
+  case elemIndex varName variableNames of
+      Just index -> index
+      Nothing -> throw $ VariableLookupException varName variableNames
+
+headTermToElement :: [Text] -> Term -> RuleElement
+headTermToElement variableNames (Var name) = 
+  RuleElementVariable $ lookupVariable name variableNames
+headTermToElement _ constant = RuleElementConstant constant
 

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

@@ -21,6 +21,7 @@ import Datalog.Rules
 import Datalog.NaiveDatabase
 import Datalog.NaiveDatabase qualified as NaiveDatabase
 import Test.Hspec
+import Datalog.DatalogDB
 
 spec :: Spec
 spec = do